You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
984 lines
32 KiB
Plaintext
984 lines
32 KiB
Plaintext
15 years ago
|
#
|
||
|
|
# Toolbar
|
||
|
|
# ----------------------------------------------------------------------
|
||
|
|
#
|
||
|
|
# The Toolbar command creates a new window (given by the pathName
|
||
|
|
# argument) and makes it into a Tool Bar widget. Additional options,
|
||
|
|
# described above may be specified on the command line or in the
|
||
|
|
# option database to configure aspects of the Toolbar such as its
|
||
|
|
# colors, font, and orientation. The Toolbar command returns its
|
||
|
|
# pathName argument. At the time this command is invoked, there
|
||
|
|
# must not exist a window named pathName, but pathName's parent
|
||
|
|
# must exist.
|
||
|
|
#
|
||
|
|
# A Toolbar is a widget that displays a collection of widgets arranged
|
||
|
|
# either in a row or a column (depending on the value of the -orient
|
||
|
|
# option). This collection of widgets is usually for user convenience
|
||
|
|
# to give access to a set of commands or settings. Any widget may be
|
||
|
|
# placed on a Toolbar. However, command or value-oriented widgets (such
|
||
|
|
# as button, radiobutton, etc.) are usually the most useful kind of
|
||
|
|
# widgets to appear on a Toolbar.
|
||
|
|
#
|
||
|
|
# WISH LIST:
|
||
|
|
# This section lists possible future enhancements.
|
||
|
|
#
|
||
|
|
# Toggle between text and image/bitmap so that the toolbar could
|
||
|
|
# display either all text or all image/bitmaps.
|
||
|
|
# Implementation of the -toolbarfile option that allows toolbar
|
||
|
|
# add commands to be read in from a file.
|
||
|
|
# ----------------------------------------------------------------------
|
||
|
|
# AUTHOR: Bill W. Scott EMAIL: bscott@spd.dsccc.com
|
||
|
|
#
|
||
|
|
# @(#) $Id: toolbar.itk,v 1.5 2001/08/17 19:05:54 smithc Exp $
|
||
|
|
# ----------------------------------------------------------------------
|
||
|
|
# Copyright (c) 1995 DSC Technologies Corporation
|
||
|
|
# ======================================================================
|
||
|
|
# Permission to use, copy, modify, distribute and license this software
|
||
|
|
# and its documentation for any purpose, and without fee or written
|
||
|
|
# agreement with DSC, is hereby granted, provided that the above copyright
|
||
|
|
# notice appears in all copies and that both the copyright notice and
|
||
|
|
# warranty disclaimer below appear in supporting documentation, and that
|
||
|
|
# the names of DSC Technologies Corporation or DSC Communications
|
||
|
|
# Corporation not be used in advertising or publicity pertaining to the
|
||
|
|
# software without specific, written prior permission.
|
||
|
|
#
|
||
|
|
# DSC DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING
|
||
|
|
# ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, AND NON-
|
||
|
|
# INFRINGEMENT. THIS SOFTWARE IS PROVIDED ON AN "AS IS" BASIS, AND THE
|
||
|
|
# AUTHORS AND DISTRIBUTORS HAVE NO OBLIGATION TO PROVIDE MAINTENANCE,
|
||
|
|
# SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. IN NO EVENT SHALL
|
||
|
|
# DSC BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR
|
||
|
|
# ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
|
||
|
|
# WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTUOUS ACTION,
|
||
|
|
# ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
|
||
|
|
# SOFTWARE.
|
||
|
|
# ======================================================================
|
||
|
|
|
||
|
|
#
|
||
|
|
# Default resources.
|
||
|
|
#
|
||
|
|
option add *Toolbar*padX 5 widgetDefault
|
||
|
|
option add *Toolbar*padY 5 widgetDefault
|
||
|
|
option add *Toolbar*orient horizontal widgetDefault
|
||
|
|
option add *Toolbar*highlightThickness 0 widgetDefault
|
||
|
|
option add *Toolbar*indicatorOn false widgetDefault
|
||
|
|
option add *Toolbar*selectColor [. cget -bg] widgetDefault
|
||
|
|
|
||
|
|
#
|
||
|
|
# Usual options.
|
||
|
|
#
|
||
|
|
itk::usual Toolbar {
|
||
|
|
keep -activebackground -activeforeground -background -balloonbackground \
|
||
|
|
-balloondelay1 -balloondelay2 -balloonfont -balloonforeground \
|
||
|
|
-borderwidth -cursor -disabledforeground -font -foreground \
|
||
|
|
-highlightbackground -highlightcolor -highlightthickness \
|
||
|
|
-insertbackground -insertforeground -selectbackground \
|
||
|
|
-selectborderwidth -selectcolor -selectforeground -troughcolor
|
||
|
|
}
|
||
|
|
|
||
|
|
# ------------------------------------------------------------------
|
||
|
|
# TOOLBAR
|
||
|
|
# ------------------------------------------------------------------
|
||
|
|
itcl::class iwidgets::Toolbar {
|
||
|
|
inherit itk::Widget
|
||
|
|
|
||
|
|
constructor {args} {}
|
||
|
|
destructor {}
|
||
|
|
|
||
|
|
itk_option define -balloonbackground \
|
||
|
|
balloonBackground BalloonBackground yellow
|
||
|
|
itk_option define -balloonforeground \
|
||
|
|
balloonForeground BalloonForeground black
|
||
|
|
itk_option define -balloonfont balloonFont BalloonFont 6x10
|
||
|
|
itk_option define -balloondelay1 \
|
||
|
|
balloonDelay1 BalloonDelay1 1000
|
||
|
|
itk_option define -balloondelay2 \
|
||
|
|
balloonDelay2 BalloonDelay2 200
|
||
|
|
itk_option define -helpvariable helpVariable HelpVariable {}
|
||
|
|
itk_option define -orient orient Orient "horizontal"
|
||
|
|
|
||
|
|
#
|
||
|
|
# The following options implement propogated configurations to
|
||
|
|
# any widget that might be added to us. The problem is this is
|
||
|
|
# not deterministic as someone might add a new kind of widget with
|
||
|
|
# and option like -armbackground, so we would not be aware of
|
||
|
|
# this kind of option. Anyway we support as many of the obvious
|
||
|
|
# ones that we can. They can always configure them with itemconfigures.
|
||
|
|
#
|
||
|
|
itk_option define -activebackground activeBackground Foreground #c3c3c3
|
||
|
|
itk_option define -activeforeground activeForeground Background Black
|
||
|
|
itk_option define -background background Background #d9d9d9
|
||
|
|
itk_option define -borderwidth borderWidth BorderWidth 2
|
||
|
|
itk_option define -cursor cursor Cursor {}
|
||
|
|
itk_option define -disabledforeground \
|
||
|
|
disabledForeground DisabledForeground #a3a3a3
|
||
|
|
itk_option define -font \
|
||
|
|
font Font "-Adobe-Helvetica-Bold-R-Normal--*-120-*-*-*-*-*-*"
|
||
|
|
itk_option define -foreground foreground Foreground #000000000000
|
||
|
|
itk_option define -highlightbackground \
|
||
|
|
highlightBackground HighlightBackground #d9d9d9
|
||
|
|
itk_option define -highlightcolor highlightColor HighlightColor Black
|
||
|
|
itk_option define -highlightthickness \
|
||
|
|
highlightThickness HighlightThickness 0
|
||
|
|
itk_option define -insertforeground insertForeground Background #c3c3c3
|
||
|
|
itk_option define -insertbackground insertBackground Foreground Black
|
||
|
|
itk_option define -selectbackground selectBackground Foreground #c3c3c3
|
||
|
|
itk_option define -selectborderwidth selectBorderWidth BorderWidth {}
|
||
|
|
itk_option define -selectcolor selectColor Background #b03060
|
||
|
|
itk_option define -selectforeground selectForeground Background Black
|
||
|
|
itk_option define -state state State normal
|
||
|
|
itk_option define -troughcolor troughColor Background #c3c3c3
|
||
|
|
|
||
|
|
public method add {widgetCommand name args}
|
||
|
|
public method delete {args}
|
||
|
|
public method index {index}
|
||
|
|
public method insert {beforeIndex widgetCommand name args}
|
||
|
|
public method itemcget {index args}
|
||
|
|
public method itemconfigure {index args}
|
||
|
|
|
||
|
|
public method _resetBalloonTimer {}
|
||
|
|
public method _startBalloonDelay {window}
|
||
|
|
public method _stopBalloonDelay {window balloonClick}
|
||
|
|
|
||
|
|
private method _deleteWidgets {index1 index2}
|
||
|
|
private method _addWidget {widgetCommand name args}
|
||
|
|
private method _index {toolList index}
|
||
|
|
private method _getAttachedOption {optionListName widget args retValue}
|
||
|
|
private method _setAttachedOption {optionListName widget option args}
|
||
|
|
private method _packToolbar {}
|
||
|
|
|
||
|
|
public method hideHelp {}
|
||
|
|
public method showHelp {window}
|
||
|
|
public method showBalloon {window}
|
||
|
|
public method hideBalloon {}
|
||
|
|
|
||
|
|
private variable _balloonTimer 0
|
||
|
|
private variable _balloonAfterID 0
|
||
|
|
private variable _balloonClick false
|
||
|
|
|
||
|
|
private variable _interior {}
|
||
|
|
private variable _initialMapping 1 ;# Is this the first mapping?
|
||
|
|
private variable _toolList {} ;# List of all widgets on toolbar
|
||
|
|
private variable _opts ;# New options for child widgets
|
||
|
|
private variable _currHelpWidget {} ;# Widget currently displaying help for
|
||
|
|
private variable _hintWindow {} ;# Balloon help bubble.
|
||
|
|
|
||
|
|
# list of options we want to propogate to widgets added to toolbar.
|
||
|
|
private common _optionList {
|
||
|
|
-activebackground \
|
||
|
|
-activeforeground \
|
||
|
|
-background \
|
||
|
|
-borderwidth \
|
||
|
|
-cursor \
|
||
|
|
-disabledforeground \
|
||
|
|
-font \
|
||
|
|
-foreground \
|
||
|
|
-highlightbackground \
|
||
|
|
-highlightcolor \
|
||
|
|
-highlightthickness \
|
||
|
|
-insertbackground \
|
||
|
|
-insertforeground \
|
||
|
|
-selectbackground \
|
||
|
|
-selectborderwidth \
|
||
|
|
-selectcolor \
|
||
|
|
-selectforeground \
|
||
|
|
-state \
|
||
|
|
-troughcolor \
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# ------------------------------------------------------------------
|
||
|
|
# CONSTRUCTOR
|
||
|
|
# ------------------------------------------------------------------
|
||
|
|
itcl::body iwidgets::Toolbar::constructor {args} {
|
||
|
|
component hull configure -borderwidth 0
|
||
|
|
set _interior $itk_interior
|
||
|
|
|
||
|
|
#
|
||
|
|
# Handle configs
|
||
|
|
#
|
||
|
|
eval itk_initialize $args
|
||
|
|
|
||
|
|
# build balloon help window
|
||
|
|
set _hintWindow [toplevel $itk_component(hull).balloonHintWindow]
|
||
|
|
wm withdraw $_hintWindow
|
||
|
|
label $_hintWindow.label \
|
||
|
|
-foreground $itk_option(-balloonforeground) \
|
||
|
|
-background $itk_option(-balloonbackground) \
|
||
|
|
-font $itk_option(-balloonfont) \
|
||
|
|
-relief raised \
|
||
|
|
-borderwidth 1
|
||
|
|
pack $_hintWindow.label
|
||
|
|
|
||
|
|
# ... Attach help handler to this widget
|
||
|
|
bind toolbar-help-$itk_component(hull) \
|
||
|
|
<Enter> "+[itcl::code $this showHelp %W]"
|
||
|
|
bind toolbar-help-$itk_component(hull) \
|
||
|
|
<Leave> "+[itcl::code $this hideHelp]"
|
||
|
|
|
||
|
|
# ... Set up Microsoft style balloon help display.
|
||
|
|
set _balloonTimer $itk_option(-balloondelay1)
|
||
|
|
bind $_interior \
|
||
|
|
<Leave> "+[itcl::code $this _resetBalloonTimer]"
|
||
|
|
bind toolbar-balloon-$itk_component(hull) \
|
||
|
|
<Enter> "+[itcl::code $this _startBalloonDelay %W]"
|
||
|
|
bind toolbar-balloon-$itk_component(hull) \
|
||
|
|
<Leave> "+[itcl::code $this _stopBalloonDelay %W false]"
|
||
|
|
bind toolbar-balloon-$itk_component(hull) \
|
||
|
|
<Button-1> "+[itcl::code $this _stopBalloonDelay %W true]"
|
||
|
|
}
|
||
|
|
|
||
|
|
#
|
||
|
|
# Provide a lowercase access method for the Toolbar class
|
||
|
|
#
|
||
|
|
proc ::iwidgets::toolbar {pathName args} {
|
||
|
|
uplevel ::iwidgets::Toolbar $pathName $args
|
||
|
|
}
|
||
|
|
|
||
|
|
# ------------------------------------------------------------------
|
||
|
|
# DESTURCTOR
|
||
|
|
# ------------------------------------------------------------------
|
||
|
|
itcl::body iwidgets::Toolbar::destructor {} {
|
||
|
|
if {$_balloonAfterID != 0} {after cancel $_balloonAfterID}
|
||
|
|
}
|
||
|
|
|
||
|
|
# ------------------------------------------------------------------
|
||
|
|
# OPTIONS
|
||
|
|
# ------------------------------------------------------------------
|
||
|
|
|
||
|
|
# ------------------------------------------------------------------
|
||
|
|
# OPTION -balloonbackground
|
||
|
|
# ------------------------------------------------------------------
|
||
|
|
itcl::configbody iwidgets::Toolbar::balloonbackground {
|
||
|
|
if { $_hintWindow != {} } {
|
||
|
|
if { $itk_option(-balloonbackground) != {} } {
|
||
|
|
$_hintWindow.label configure \
|
||
|
|
-background $itk_option(-balloonbackground)
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# ------------------------------------------------------------------
|
||
|
|
# OPTION -balloonforeground
|
||
|
|
# ------------------------------------------------------------------
|
||
|
|
itcl::configbody iwidgets::Toolbar::balloonforeground {
|
||
|
|
if { $_hintWindow != {} } {
|
||
|
|
if { $itk_option(-balloonforeground) != {} } {
|
||
|
|
$_hintWindow.label configure \
|
||
|
|
-foreground $itk_option(-balloonforeground)
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# ------------------------------------------------------------------
|
||
|
|
# OPTION -balloonfont
|
||
|
|
# ------------------------------------------------------------------
|
||
|
|
itcl::configbody iwidgets::Toolbar::balloonfont {
|
||
|
|
if { $_hintWindow != {} } {
|
||
|
|
if { $itk_option(-balloonfont) != {} } {
|
||
|
|
$_hintWindow.label configure \
|
||
|
|
-font $itk_option(-balloonfont)
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# ------------------------------------------------------------------
|
||
|
|
# OPTION: -orient
|
||
|
|
#
|
||
|
|
# Position buttons either horizontally or vertically.
|
||
|
|
# ------------------------------------------------------------------
|
||
|
|
itcl::configbody iwidgets::Toolbar::orient {
|
||
|
|
switch $itk_option(-orient) {
|
||
|
|
"horizontal" - "vertical" {
|
||
|
|
_packToolbar
|
||
|
|
}
|
||
|
|
default {error "Invalid orientation. Must be either \
|
||
|
|
horizontal or vertical"
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# ------------------------------------------------------------------
|
||
|
|
# METHODS
|
||
|
|
# ------------------------------------------------------------------
|
||
|
|
|
||
|
|
# -------------------------------------------------------------
|
||
|
|
# METHOD: add widgetCommand name ?option value?
|
||
|
|
#
|
||
|
|
# Adds a widget with the command widgetCommand whose name is
|
||
|
|
# name to the Toolbar. If widgetCommand is radiobutton
|
||
|
|
# or checkbutton, its packing is slightly padded to match the
|
||
|
|
# geometry of button widgets.
|
||
|
|
# -------------------------------------------------------------
|
||
|
|
itcl::body iwidgets::Toolbar::add { widgetCommand name args } {
|
||
|
|
|
||
|
|
eval "_addWidget $widgetCommand $name $args"
|
||
|
|
|
||
|
|
lappend _toolList $itk_component($name)
|
||
|
|
|
||
|
|
if { $widgetCommand == "radiobutton" || \
|
||
|
|
$widgetCommand == "checkbutton" } {
|
||
|
|
set iPad 1
|
||
|
|
} else {
|
||
|
|
set iPad 0
|
||
|
|
}
|
||
|
|
|
||
|
|
# repack the tool bar
|
||
|
|
_packToolbar
|
||
|
|
|
||
|
|
return $itk_component($name)
|
||
|
|
|
||
|
|
}
|
||
|
|
|
||
|
|
# -------------------------------------------------------------
|
||
|
|
#
|
||
|
|
# METHOD: delete index ?index2?
|
||
|
|
#
|
||
|
|
# This command deletes all components between index and
|
||
|
|
# index2 inclusive. If index2 is omitted then it defaults
|
||
|
|
# to index. Returns an empty string
|
||
|
|
#
|
||
|
|
# -------------------------------------------------------------
|
||
|
|
itcl::body iwidgets::Toolbar::delete { args } {
|
||
|
|
# empty toolbar
|
||
|
|
if { $_toolList == {} } {
|
||
|
|
error "can't delete widget, no widgets in the Toolbar \
|
||
|
|
\"$itk_component(hull)\""
|
||
|
|
}
|
||
|
|
|
||
|
|
set len [llength $args]
|
||
|
|
switch -- $len {
|
||
|
|
1 {
|
||
|
|
set fromWidget [_index $_toolList [lindex $args 0]]
|
||
|
|
|
||
|
|
if { $fromWidget < 0 || $fromWidget >= [llength $_toolList] } {
|
||
|
|
error "bad Toolbar widget index in delete method: \
|
||
|
|
should be between 0 and [expr {[llength $_toolList] - 1} ]"
|
||
|
|
}
|
||
|
|
|
||
|
|
set toWidget $fromWidget
|
||
|
|
_deleteWidgets $fromWidget $toWidget
|
||
|
|
}
|
||
|
|
|
||
|
|
2 {
|
||
|
|
set fromWidget [_index $_toolList [lindex $args 0]]
|
||
|
|
|
||
|
|
if { $fromWidget < 0 || $fromWidget >= [llength $_toolList] } {
|
||
|
|
error "bad Toolbar widget index1 in delete method: \
|
||
|
|
should be between 0 and [expr {[llength $_toolList] - 1} ]"
|
||
|
|
}
|
||
|
|
|
||
|
|
set toWidget [_index $_toolList [lindex $args 1]]
|
||
|
|
|
||
|
|
if { $toWidget < 0 || $toWidget >= [llength $_toolList] } {
|
||
|
|
error "bad Toolbar widget index2 in delete method: \
|
||
|
|
should be between 0 and [expr {[llength $_toolList] - 1} ]"
|
||
|
|
}
|
||
|
|
|
||
|
|
if { $fromWidget > $toWidget } {
|
||
|
|
error "bad Toolbar widget index1 in delete method: \
|
||
|
|
index1 is greater than index2"
|
||
|
|
}
|
||
|
|
|
||
|
|
_deleteWidgets $fromWidget $toWidget
|
||
|
|
}
|
||
|
|
|
||
|
|
default {
|
||
|
|
# ... too few/many parameters passed
|
||
|
|
error "wrong # args: should be \
|
||
|
|
\"$itk_component(hull) delete index1 ?index2?\""
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
return {}
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
# -------------------------------------------------------------
|
||
|
|
#
|
||
|
|
# METHOD: index index
|
||
|
|
#
|
||
|
|
# Returns the widget's numerical index for the entry corresponding
|
||
|
|
# to index. If index is not found, -1 is returned
|
||
|
|
#
|
||
|
|
# -------------------------------------------------------------
|
||
|
|
itcl::body iwidgets::Toolbar::index { index } {
|
||
|
|
|
||
|
|
return [_index $_toolList $index]
|
||
|
|
|
||
|
|
}
|
||
|
|
|
||
|
|
# -------------------------------------------------------------
|
||
|
|
#
|
||
|
|
# METHOD: insert beforeIndex widgetCommand name ?option value?
|
||
|
|
#
|
||
|
|
# Insert a new component named name with the command
|
||
|
|
# widgetCommand before the com ponent specified by beforeIndex.
|
||
|
|
# If widgetCommand is radiobutton or checkbutton, its packing
|
||
|
|
# is slightly padded to match the geometry of button widgets.
|
||
|
|
#
|
||
|
|
# -------------------------------------------------------------
|
||
|
|
itcl::body iwidgets::Toolbar::insert { beforeIndex widgetCommand name args } {
|
||
|
|
|
||
|
|
set beforeIndex [_index $_toolList $beforeIndex]
|
||
|
|
|
||
|
|
if {$beforeIndex < 0 || $beforeIndex > [llength $_toolList] } {
|
||
|
|
error "bad toolbar entry index $beforeIndex"
|
||
|
|
}
|
||
|
|
|
||
|
|
eval "_addWidget $widgetCommand $name $args"
|
||
|
|
|
||
|
|
# linsert into list
|
||
|
|
set _toolList [linsert $_toolList $beforeIndex $itk_component($name)]
|
||
|
|
|
||
|
|
# repack the tool bar
|
||
|
|
_packToolbar
|
||
|
|
|
||
|
|
return $itk_component($name)
|
||
|
|
|
||
|
|
}
|
||
|
|
|
||
|
|
# ----------------------------------------------------------------------
|
||
|
|
# METHOD: itemcget index ?option?
|
||
|
|
#
|
||
|
|
# Returns the value for the option setting of the widget at index $index.
|
||
|
|
# index can be numeric or widget name
|
||
|
|
#
|
||
|
|
# ----------------------------------------------------------------------
|
||
|
|
itcl::body iwidgets::Toolbar::itemcget { index args} {
|
||
|
|
|
||
|
|
return [lindex [eval itemconfigure $index $args] 4]
|
||
|
|
}
|
||
|
|
|
||
|
|
# -------------------------------------------------------------
|
||
|
|
#
|
||
|
|
# METHOD: itemconfigure index ?option? ?value? ?option value...?
|
||
|
|
#
|
||
|
|
# Query or modify the configuration options of the widget of
|
||
|
|
# the Toolbar specified by index. If no option is specified,
|
||
|
|
# returns a list describing all of the available options for
|
||
|
|
# index (see Tk_ConfigureInfo for information on the format
|
||
|
|
# of this list). If option is specified with no value, then
|
||
|
|
# the command returns a list describing the one named option
|
||
|
|
# (this list will be identical to the corresponding sublist
|
||
|
|
# of the value returned if no option is specified). If one
|
||
|
|
# or more option-value pairs are specified, then the command
|
||
|
|
# modifies the given widget option(s) to have the given
|
||
|
|
# value(s); in this case the command returns an empty string.
|
||
|
|
# The component type of index determines the valid available options.
|
||
|
|
#
|
||
|
|
# -------------------------------------------------------------
|
||
|
|
itcl::body iwidgets::Toolbar::itemconfigure { index args } {
|
||
|
|
|
||
|
|
# Get a numeric index.
|
||
|
|
set index [_index $_toolList $index]
|
||
|
|
|
||
|
|
# Get the tool path
|
||
|
|
set toolPath [lindex $_toolList $index]
|
||
|
|
|
||
|
|
set len [llength $args]
|
||
|
|
|
||
|
|
switch $len {
|
||
|
|
0 {
|
||
|
|
# show all options
|
||
|
|
# ''''''''''''''''
|
||
|
|
|
||
|
|
# support display of -helpstr and -balloonstr configs
|
||
|
|
set optList [$toolPath configure]
|
||
|
|
|
||
|
|
## @@@ might want to use _getAttachedOption instead...
|
||
|
|
if { [info exists _opts($toolPath,-helpstr)] } {
|
||
|
|
set value $_opts($toolPath,-helpstr)
|
||
|
|
} else {
|
||
|
|
set value {}
|
||
|
|
}
|
||
|
|
lappend optList [list -helpstr helpStr HelpStr {} $value]
|
||
|
|
if { [info exists _opts($toolPath,-balloonstr)] } {
|
||
|
|
set value $_opts($toolPath,-balloonstr)
|
||
|
|
} else {
|
||
|
|
set value {}
|
||
|
|
}
|
||
|
|
lappend optList [list -balloonstr balloonStr BalloonStr {} $value]
|
||
|
|
return $optList
|
||
|
|
}
|
||
|
|
1 {
|
||
|
|
# show only option specified
|
||
|
|
# ''''''''''''''''''''''''''
|
||
|
|
# did we satisfy the option get request?
|
||
|
|
|
||
|
|
if { [regexp -- {-helpstr} $args] } {
|
||
|
|
if { [info exists _opts($toolPath,-helpstr)] } {
|
||
|
|
set value $_opts($toolPath,-helpstr)
|
||
|
|
} else {
|
||
|
|
set value {}
|
||
|
|
}
|
||
|
|
return [list -helpstr helpStr HelpStr {} $value]
|
||
|
|
} elseif { [regexp -- {-balloonstr} $args] } {
|
||
|
|
if { [info exists _opts($toolPath,-balloonstr)] } {
|
||
|
|
set value $_opts($toolPath,-balloonstr)
|
||
|
|
} else {
|
||
|
|
set value {}
|
||
|
|
}
|
||
|
|
return [list -balloonstr balloonStr BalloonStr {} $value]
|
||
|
|
} else {
|
||
|
|
return [eval $toolPath configure $args]
|
||
|
|
}
|
||
|
|
|
||
|
|
}
|
||
|
|
default {
|
||
|
|
# ... do a normal configure
|
||
|
|
|
||
|
|
# first screen for all our child options we are adding
|
||
|
|
_setAttachedOption \
|
||
|
|
_opts \
|
||
|
|
$toolPath \
|
||
|
|
"-helpstr" \
|
||
|
|
$args
|
||
|
|
|
||
|
|
_setAttachedOption \
|
||
|
|
_opts \
|
||
|
|
$toolPath \
|
||
|
|
"-balloonstr" \
|
||
|
|
$args
|
||
|
|
|
||
|
|
# with a clean args list do a configure
|
||
|
|
|
||
|
|
# if the stripping process brought us down to no options
|
||
|
|
# to set, then forget the configure of widget.
|
||
|
|
if { [llength $args] != 0 } {
|
||
|
|
return [eval $toolPath configure $args]
|
||
|
|
} else {
|
||
|
|
return ""
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
}
|
||
|
|
|
||
|
|
# -------------------------------------------------------------
|
||
|
|
#
|
||
|
|
# METHOD: _resetBalloonDelay1
|
||
|
|
#
|
||
|
|
# Sets the delay that will occur before a balloon could be popped
|
||
|
|
# up to balloonDelay1
|
||
|
|
#
|
||
|
|
# -------------------------------------------------------------
|
||
|
|
itcl::body iwidgets::Toolbar::_resetBalloonTimer {} {
|
||
|
|
set _balloonTimer $itk_option(-balloondelay1)
|
||
|
|
|
||
|
|
# reset the <1> longer delay
|
||
|
|
set _balloonClick false
|
||
|
|
}
|
||
|
|
|
||
|
|
# -------------------------------------------------------------
|
||
|
|
#
|
||
|
|
# METHOD: _startBalloonDelay
|
||
|
|
#
|
||
|
|
# Starts waiting to pop up a balloon id
|
||
|
|
#
|
||
|
|
# -------------------------------------------------------------
|
||
|
|
itcl::body iwidgets::Toolbar::_startBalloonDelay {window} {
|
||
|
|
if {$_balloonAfterID != 0} {
|
||
|
|
after cancel $_balloonAfterID
|
||
|
|
}
|
||
|
|
set _balloonAfterID [after $_balloonTimer [itcl::code $this showBalloon $window]]
|
||
|
|
}
|
||
|
|
|
||
|
|
# -------------------------------------------------------------
|
||
|
|
#
|
||
|
|
# METHOD: _stopBalloonDelay
|
||
|
|
#
|
||
|
|
# This method will stop the timer for a balloon popup if one is
|
||
|
|
# in progress. If however there is already a balloon window up
|
||
|
|
# it will hide the balloon window and set timing to delay 2 stage.
|
||
|
|
#
|
||
|
|
# -------------------------------------------------------------
|
||
|
|
itcl::body iwidgets::Toolbar::_stopBalloonDelay { window balloonClick } {
|
||
|
|
|
||
|
|
# If <1> then got a click cancel
|
||
|
|
if { $balloonClick } {
|
||
|
|
set _balloonClick true
|
||
|
|
}
|
||
|
|
if { $_balloonAfterID != 0 } {
|
||
|
|
after cancel $_balloonAfterID
|
||
|
|
set _balloonAfterID 0
|
||
|
|
} else {
|
||
|
|
hideBalloon
|
||
|
|
|
||
|
|
# If this was cancelled with a <1> use longer delay.
|
||
|
|
if { $_balloonClick } {
|
||
|
|
set _balloonTimer $itk_option(-balloondelay1)
|
||
|
|
} else {
|
||
|
|
set _balloonTimer $itk_option(-balloondelay2)
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# -------------------------------------------------------------
|
||
|
|
# PRIVATE METHOD: _addWidget
|
||
|
|
#
|
||
|
|
# widgetCommand : command to invoke to create the added widget
|
||
|
|
# name : name of the new widget to add
|
||
|
|
# args : options for the widget create command
|
||
|
|
#
|
||
|
|
# Looks for -helpstr, -balloonstr and grabs them, strips from
|
||
|
|
# args list. Then tries to add a component and keeps based
|
||
|
|
# on known type. If it fails, it tries to clean up. Then it
|
||
|
|
# binds handlers for helpstatus and balloon help.
|
||
|
|
#
|
||
|
|
# Returns the path of the widget added.
|
||
|
|
#
|
||
|
|
# -------------------------------------------------------------
|
||
|
|
itcl::body iwidgets::Toolbar::_addWidget { widgetCommand name args } {
|
||
|
|
|
||
|
|
# ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,
|
||
|
|
# Add the widget to the tool bar
|
||
|
|
# '''''''''''''''''''''''''''''''''''''''''''''''''''''
|
||
|
|
|
||
|
|
# ... Strip out and save the -helpstr, -balloonstr options from args
|
||
|
|
# and save it in _opts
|
||
|
|
_setAttachedOption \
|
||
|
|
_opts \
|
||
|
|
$_interior.$name \
|
||
|
|
-helpstr \
|
||
|
|
$args
|
||
|
|
|
||
|
|
_setAttachedOption \
|
||
|
|
_opts \
|
||
|
|
$_interior.$name \
|
||
|
|
-balloonstr \
|
||
|
|
$args
|
||
|
|
|
||
|
|
|
||
|
|
# ... Add the new widget as a component (catch an error if occurs)
|
||
|
|
set createFailed [catch {
|
||
|
|
itk_component add $name {
|
||
|
|
eval $widgetCommand $_interior.$name $args
|
||
|
|
} {
|
||
|
|
}
|
||
|
|
} errMsg]
|
||
|
|
|
||
|
|
# ... Clean up if the create failed, and exit.
|
||
|
|
# The _opts list if it has -helpstr, -balloonstr just entered for
|
||
|
|
# this, it must be cleaned up.
|
||
|
|
if { $createFailed } {
|
||
|
|
# clean up
|
||
|
|
if {![catch {set _opts($_interior.$name,-helpstr)}]} {
|
||
|
|
set lastIndex [\
|
||
|
|
expr {[llength \
|
||
|
|
$_opts($_interior.$name,-helpstr) ]-1}]
|
||
|
|
lreplace $_opts($_interior.$name,-helpstr) \
|
||
|
|
$lastIndex $lastIndex ""
|
||
|
|
}
|
||
|
|
if {![catch {set _opts($_interior.$name,-balloonstr)}]} {
|
||
|
|
set lastIndex [\
|
||
|
|
expr {[llength \
|
||
|
|
$_opts($_interior.$name,-balloonstr) ]-1}]
|
||
|
|
lreplace $_opts($_interior.$name,-balloonstr) \
|
||
|
|
$lastIndex $lastIndex ""
|
||
|
|
}
|
||
|
|
error $errMsg
|
||
|
|
}
|
||
|
|
|
||
|
|
# ... Add in dynamic options that apply from the _optionList
|
||
|
|
foreach optionSet [$itk_component($name) configure] {
|
||
|
|
set option [lindex $optionSet 0]
|
||
|
|
if { [lsearch $_optionList $option] != -1 } {
|
||
|
|
itk_option add $name.$option
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
bindtags $itk_component($name) \
|
||
|
|
[linsert [bindtags $itk_component($name)] end \
|
||
|
|
toolbar-help-$itk_component(hull)]
|
||
|
|
bindtags $itk_component($name) \
|
||
|
|
[linsert [bindtags $itk_component($name)] end \
|
||
|
|
toolbar-balloon-$itk_component(hull)]
|
||
|
|
|
||
|
|
return $itk_component($name)
|
||
|
|
}
|
||
|
|
|
||
|
|
# -------------------------------------------------------------
|
||
|
|
#
|
||
|
|
# PRIVATE METHOD: _deleteWidgets
|
||
|
|
#
|
||
|
|
# deletes widget range by numerical index numbers.
|
||
|
|
#
|
||
|
|
# -------------------------------------------------------------
|
||
|
|
itcl::body iwidgets::Toolbar::_deleteWidgets { index1 index2 } {
|
||
|
|
|
||
|
|
for { set index $index1 } { $index <= $index2 } { incr index } {
|
||
|
|
|
||
|
|
# kill the widget
|
||
|
|
set component [lindex $_toolList $index]
|
||
|
|
destroy $component
|
||
|
|
|
||
|
|
}
|
||
|
|
|
||
|
|
# physically remove the page
|
||
|
|
set _toolList [lreplace $_toolList $index1 $index2]
|
||
|
|
|
||
|
|
}
|
||
|
|
|
||
|
|
# -------------------------------------------------------------
|
||
|
|
# PRIVATE METHOD: _index
|
||
|
|
#
|
||
|
|
# toolList : list of widget names to search thru if index
|
||
|
|
# is non-numeric
|
||
|
|
# index : either number, 'end', 'last', or pattern
|
||
|
|
#
|
||
|
|
# _index takes takes the value $index converts it to
|
||
|
|
# a numeric identifier. If the value is not already
|
||
|
|
# an integer it looks it up in the $toolList array.
|
||
|
|
# If it fails it returns -1
|
||
|
|
#
|
||
|
|
# -------------------------------------------------------------
|
||
|
|
itcl::body iwidgets::Toolbar::_index { toolList index } {
|
||
|
|
|
||
|
|
switch -- $index {
|
||
|
|
end - last {
|
||
|
|
set number [expr {[llength $toolList] -1}]
|
||
|
|
}
|
||
|
|
default {
|
||
|
|
# is it a number already? Then just use the number
|
||
|
|
if { [regexp {^[0-9]+$} $index] } {
|
||
|
|
set number $index
|
||
|
|
# check bounds
|
||
|
|
if { $number < 0 || $number >= [llength $toolList] } {
|
||
|
|
set number -1
|
||
|
|
}
|
||
|
|
# otherwise it is a widget name
|
||
|
|
} else {
|
||
|
|
if { [catch { set itk_component($index) } ] } {
|
||
|
|
set number -1
|
||
|
|
} else {
|
||
|
|
set number [lsearch -exact $toolList \
|
||
|
|
$itk_component($index)]
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
return $number
|
||
|
|
}
|
||
|
|
|
||
|
|
# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||
|
|
# STATUS HELP for linking to helpVariable
|
||
|
|
# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||
|
|
# -------------------------------------------------------------
|
||
|
|
#
|
||
|
|
# PUBLIC METHOD: hideHelp
|
||
|
|
#
|
||
|
|
# Bound to the <Leave> event on a toolbar widget. This clears the
|
||
|
|
# status widget help area and resets the help entry.
|
||
|
|
#
|
||
|
|
# -------------------------------------------------------------
|
||
|
|
itcl::body iwidgets::Toolbar::hideHelp {} {
|
||
|
|
if { $itk_option(-helpvariable) != {} } {
|
||
|
|
upvar #0 $itk_option(-helpvariable) helpvar
|
||
|
|
set helpvar {}
|
||
|
|
}
|
||
|
|
set _currHelpWidget {}
|
||
|
|
}
|
||
|
|
|
||
|
|
# -------------------------------------------------------------
|
||
|
|
#
|
||
|
|
# PUBLIC METHOD: showHelp
|
||
|
|
#
|
||
|
|
# Bound to the <Motion> event on a tool bar widget. This puts the
|
||
|
|
# help string associated with the tool bar widget into the
|
||
|
|
# status widget help area. If no help exists for the current
|
||
|
|
# entry, the status widget is cleared.
|
||
|
|
#
|
||
|
|
# -------------------------------------------------------------
|
||
|
|
itcl::body iwidgets::Toolbar::showHelp { window } {
|
||
|
|
|
||
|
|
set widgetPath $window
|
||
|
|
# already on this item?
|
||
|
|
if { $window == $_currHelpWidget } {
|
||
|
|
return
|
||
|
|
}
|
||
|
|
|
||
|
|
set _currHelpWidget $window
|
||
|
|
|
||
|
|
# Do we have a helpvariable set on the toolbar?
|
||
|
|
if { $itk_option(-helpvariable) != {} } {
|
||
|
|
upvar #0 $itk_option(-helpvariable) helpvar
|
||
|
|
|
||
|
|
# is the -helpstr set for this widget?
|
||
|
|
set args "-helpstr"
|
||
|
|
if {[_getAttachedOption _opts \
|
||
|
|
$window args value]} {
|
||
|
|
set helpvar $value.
|
||
|
|
} else {
|
||
|
|
set helpvar {}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||
|
|
# BALLOON HELP for show/hide of hint window
|
||
|
|
# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||
|
|
# -------------------------------------------------------------
|
||
|
|
#
|
||
|
|
# PUBLIC METHOD: showBalloon
|
||
|
|
#
|
||
|
|
# -------------------------------------------------------------
|
||
|
|
itcl::body iwidgets::Toolbar::showBalloon {window} {
|
||
|
|
set _balloonClick false
|
||
|
|
set _balloonAfterID 0
|
||
|
|
# Are we still inside the window?
|
||
|
|
set mouseWindow \
|
||
|
|
[winfo containing [winfo pointerx .] [winfo pointery .]]
|
||
|
|
|
||
|
|
if { [string match $window* $mouseWindow] } {
|
||
|
|
# set up the balloonString
|
||
|
|
set args "-balloonstr"
|
||
|
|
if {[_getAttachedOption _opts \
|
||
|
|
$window args hintStr]} {
|
||
|
|
# configure the balloon help
|
||
|
|
$_hintWindow.label configure -text $hintStr
|
||
|
|
|
||
|
|
# Coordinates of the balloon
|
||
|
|
set balloonLeft \
|
||
|
|
[expr {[winfo rootx $window] + round(([winfo width $window]/2.0))}]
|
||
|
|
set balloonTop \
|
||
|
|
[expr {[winfo rooty $window] + [winfo height $window]}]
|
||
|
|
|
||
|
|
# put up balloon window
|
||
|
|
wm overrideredirect $_hintWindow 0
|
||
|
|
wm geometry $_hintWindow "+$balloonLeft+$balloonTop"
|
||
|
|
wm overrideredirect $_hintWindow 1
|
||
|
|
wm deiconify $_hintWindow
|
||
|
|
raise $_hintWindow
|
||
|
|
} else {
|
||
|
|
#NO BALLOON HELP AVAILABLE
|
||
|
|
}
|
||
|
|
} else {
|
||
|
|
#NOT IN BUTTON
|
||
|
|
}
|
||
|
|
|
||
|
|
}
|
||
|
|
|
||
|
|
# -------------------------------------------------------------
|
||
|
|
#
|
||
|
|
# PUBLIC METHOD: hideBalloon
|
||
|
|
#
|
||
|
|
# -------------------------------------------------------------
|
||
|
|
itcl::body iwidgets::Toolbar::hideBalloon {} {
|
||
|
|
wm withdraw $_hintWindow
|
||
|
|
}
|
||
|
|
|
||
|
|
# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||
|
|
# OPTION MANAGEMENT for -helpstr, -balloonstr
|
||
|
|
# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||
|
|
# -------------------------------------------------------------
|
||
|
|
# PRIVATE METHOD: _getAttachedOption
|
||
|
|
#
|
||
|
|
# optionListName : the name of the array that holds all attached
|
||
|
|
# options. It is indexed via widget,option to get
|
||
|
|
# the value.
|
||
|
|
# widget : the widget that the option is associated with
|
||
|
|
# option : the option whose value we are looking for on
|
||
|
|
# this widget.
|
||
|
|
#
|
||
|
|
# expects to be called only if the $option is length 1
|
||
|
|
# -------------------------------------------------------------
|
||
|
|
itcl::body iwidgets::Toolbar::_getAttachedOption { optionListName widget args retValue} {
|
||
|
|
|
||
|
|
# get a reference to the option, so we can change it.
|
||
|
|
upvar $args argsRef
|
||
|
|
upvar $retValue retValueRef
|
||
|
|
|
||
|
|
set success false
|
||
|
|
|
||
|
|
if { ![catch { set retValueRef \
|
||
|
|
[eval set [subst [set optionListName]]($widget,$argsRef)]}]} {
|
||
|
|
|
||
|
|
# remove the option argument
|
||
|
|
set success true
|
||
|
|
set argsRef ""
|
||
|
|
}
|
||
|
|
|
||
|
|
return $success
|
||
|
|
}
|
||
|
|
|
||
|
|
# -------------------------------------------------------------
|
||
|
|
# PRIVATE METHOD: _setAttachedOption
|
||
|
|
#
|
||
|
|
# This method allows us to attach new options to a widget. It
|
||
|
|
# catches the 'option' to be attached, strips it out of 'args'
|
||
|
|
# attaches it to the 'widget' by stuffing the value into
|
||
|
|
# 'optionList(widget,option)'
|
||
|
|
#
|
||
|
|
# optionListName: where to store the option and widget association
|
||
|
|
# widget: is the widget we want to associate the attached option
|
||
|
|
# option: is the attached option (unknown to this widget)
|
||
|
|
# args: the arg list to search and remove the option from (if found)
|
||
|
|
#
|
||
|
|
# Modifies the args parameter.
|
||
|
|
# Returns boolean indicating the success of the method
|
||
|
|
#
|
||
|
|
# -------------------------------------------------------------
|
||
|
|
itcl::body iwidgets::Toolbar::_setAttachedOption {optionListName widget option args} {
|
||
|
|
|
||
|
|
upvar args argsRef
|
||
|
|
|
||
|
|
set success false
|
||
|
|
|
||
|
|
# check for 'option' in the 'args' list for the 'widget'
|
||
|
|
set optPos [eval lsearch $args $option]
|
||
|
|
|
||
|
|
# ... found it
|
||
|
|
if { $optPos != -1 } {
|
||
|
|
# grab a copy of the option from arg list
|
||
|
|
set [subst [set optionListName]]($widget,$option) \
|
||
|
|
[eval lindex $args [expr {$optPos + 1}]]
|
||
|
|
|
||
|
|
# remove the option argument and value from the arg list
|
||
|
|
set argsRef [eval lreplace $args $optPos [expr {$optPos + 1}]]
|
||
|
|
set success true
|
||
|
|
}
|
||
|
|
# ... if not found, will leave args alone
|
||
|
|
|
||
|
|
return $success
|
||
|
|
}
|
||
|
|
|
||
|
|
# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||
|
|
# GEOMETRY MANAGEMENT for tool widgets
|
||
|
|
# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||
|
|
# -------------------------------------------------------------
|
||
|
|
#
|
||
|
|
# PRIVATE METHOD: _packToolbar
|
||
|
|
#
|
||
|
|
#
|
||
|
|
#
|
||
|
|
# -------------------------------------------------------------
|
||
|
|
itcl::body iwidgets::Toolbar::_packToolbar {} {
|
||
|
|
|
||
|
|
# forget the previous locations
|
||
|
|
foreach tool $_toolList {
|
||
|
|
pack forget $tool
|
||
|
|
}
|
||
|
|
|
||
|
|
# pack in order of _toolList.
|
||
|
|
foreach tool $_toolList {
|
||
|
|
# adjust for radios and checks to match buttons
|
||
|
|
if { [winfo class $tool] == "Radiobutton" ||
|
||
|
|
[winfo class $tool] == "Checkbutton" } {
|
||
|
|
set iPad 1
|
||
|
|
} else {
|
||
|
|
set iPad 0
|
||
|
|
}
|
||
|
|
|
||
|
|
# pack by horizontal or vertical orientation
|
||
|
|
if {$itk_option(-orient) == "horizontal" } {
|
||
|
|
pack $tool -side left -fill y \
|
||
|
|
-ipadx $iPad -ipady $iPad
|
||
|
|
} else {
|
||
|
|
pack $tool -side top -fill x \
|
||
|
|
-ipadx $iPad -ipady $iPad
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|