diff options
Diffstat (limited to 'iwidgets/generic/labeledframe.itk')
| -rw-r--r-- | iwidgets/generic/labeledframe.itk | 496 |
1 files changed, 496 insertions, 0 deletions
diff --git a/iwidgets/generic/labeledframe.itk b/iwidgets/generic/labeledframe.itk new file mode 100644 index 00000000000..59aa501707c --- /dev/null +++ b/iwidgets/generic/labeledframe.itk @@ -0,0 +1,496 @@ +# +# Labeledframe +# ---------------------------------------------------------------------- +# Implements a hull frame with a grooved relief, a label, and a +# frame childsite. +# +# The frame childsite can be filled with any widget via a derived class +# or though the use of the childsite method. This class was designed +# to be a general purpose base class for supporting the combination of +# a labeled frame and a childsite. The options include the ability to +# position the label at configurable locations within the grooved relief +# of the hull frame, and control the display of the label. +# +# To following demonstrates the different values which the "-labelpos" +# option may be set to and the resulting layout of the label when +# one executes the following command with "-labeltext" set to "LABEL": +# +# example: +# labeledframe .w -labeltext LABEL -labelpos <ne,n,nw,se,s,sw,en,e,es,wn,s,ws> +# +# ne n nw se s sw +# +# *LABEL**** **LABEL** ****LABEL* ********** ********* ********** +# * * * * * * * * * * * * +# * * * * * * * * * * * * +# * * * * * * * * * * * * +# ********** ********* ********** *LABEL**** **LABEL** ****LABEL* +# +# en e es wn s ws +# +# ********** ********* ********* ********* ********* ********** +# * * * * * * * * * * * * +# L * * * * * * L * * * * +# A * L * * * * A * L * L +# B * A * L * * B * A * A +# E * B * A * * E * B * B +# L * E * B * * L * E * E +# * * L * E * * * * L * L +# * * * * L * * * * * * * +# ********** ********** ********* ********** ********* ********** +# +# ---------------------------------------------------------------------- +# AUTHOR: John A. Tucker EMAIL: jatucker@spd.dsccc.com +# +# ====================================================================== +# Copyright (c) 1997 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 *Labeledframe.labelMargin 10 widgetDefault +option add *Labeledframe.labelFont \ + "-Adobe-Helvetica-Bold-R-Normal--*-120-*-*-*-*-*-*" widgetDefault +option add *Labeledframe.labelPos n widgetDefault +option add *Labeledframe.borderWidth 2 widgetDefault +option add *Labeledframe.relief groove widgetDefault + + +# +# Usual options. +# +itk::usual Labeledframe { + keep -background -cursor -labelfont -foreground +} + +itcl::class iwidgets::Labeledframe { + + inherit itk::Archetype + + itk_option define -ipadx iPadX IPad 0 + itk_option define -ipady iPadY IPad 0 + + itk_option define -labelmargin labelMargin LabelMargin 10 + itk_option define -labelpos labelPos LabelPos n + + constructor {args} {} + destructor {} + + # + # Public methods + # + public method childsite {} + + # + # Protected methods + # + protected { + method _positionLabel {{when later}} + method _collapseMargin {} + method _setMarginThickness {value} + method smt {value} { _setMarginThickness $value } + } + + # + # Private methods/data + # + private { + proc _initTable {} + + variable _reposition "" ;# non-null => _positionLabel pending + variable itk_hull "" + + common _LAYOUT_TABLE + } +} + +# +# Provide a lowercased access method for the Labeledframe class. +# +proc ::iwidgets::labeledframe {pathName args} { + uplevel ::iwidgets::Labeledframe $pathName $args +} + +# ----------------------------------------------------------------------------- +# CONSTRUCTOR +# ----------------------------------------------------------------------------- +itcl::body iwidgets::Labeledframe::constructor { args } { + # + # Create a window with the same name as this object + # + set itk_hull [namespace tail $this] + set itk_interior $itk_hull + + itk_component add hull { + frame $itk_hull \ + -relief groove \ + -class [namespace tail [info class]] + } { + keep -background -cursor -relief -borderwidth + rename -highlightbackground -background background Background + rename -highlightcolor -background background Background + } + bind itk-delete-$itk_hull <Destroy> "itcl::delete object $this" + + set tags [bindtags $itk_hull] + bindtags $itk_hull [linsert $tags 0 itk-delete-$itk_hull] + + # + # Create the childsite frame window + # _______ + # |_____| + # |_|X|_| + # |_____| + # + itk_component add childsite { + frame $itk_interior.childsite -highlightthickness 0 -bd 0 + } + + # + # Create the label to be positioned within the grooved relief + # of the hull frame. + # + itk_component add label { + label $itk_interior.label -highlightthickness 0 -bd 0 + } { + usual + rename -bitmap -labelbitmap labelBitmap Bitmap + rename -font -labelfont labelFont Font + rename -image -labelimage labelImage Image + rename -text -labeltext labelText Text + rename -textvariable -labelvariable labelVariable Variable + ignore -highlightthickness -highlightcolor + } + + grid $itk_component(childsite) -row 1 -column 1 -sticky nsew + grid columnconfigure $itk_interior 1 -weight 1 + grid rowconfigure $itk_interior 1 -weight 1 + + bind $itk_component(label) <Configure> +[itcl::code $this _positionLabel] + + # + # Initialize the class array of layout configuration options. Since + # this is a one time only thing. + # + _initTable + + eval itk_initialize $args + + # + # When idle, position the label. + # + _positionLabel +} + +# ----------------------------------------------------------------------------- +# DESTRUCTOR +# ----------------------------------------------------------------------------- +itcl::body iwidgets::Labeledframe::destructor {} { + + if {$_reposition != ""} { + after cancel $_reposition + } + + if {[winfo exists $itk_hull]} { + set tags [bindtags $itk_hull] + set i [lsearch $tags itk-delete-$itk_hull] + if {$i >= 0} { + bindtags $itk_hull [lreplace $tags $i $i] + } + destroy $itk_hull + } +} + +# ----------------------------------------------------------------------------- +# OPTIONS +# ----------------------------------------------------------------------------- + +# ------------------------------------------------------------------ +# OPTION: -ipadx +# +# Specifies the width of the horizontal gap from the border to the +# the child site. +# ------------------------------------------------------------------ +itcl::configbody iwidgets::Labeledframe::ipadx { + grid configure $itk_component(childsite) -padx $itk_option(-ipadx) + _positionLabel +} + +# ------------------------------------------------------------------ +# OPTION: -ipady +# +# Specifies the width of the vertical gap from the border to the +# the child site. +# ------------------------------------------------------------------ +itcl::configbody iwidgets::Labeledframe::ipady { + grid configure $itk_component(childsite) -pady $itk_option(-ipady) + _positionLabel +} + +# ----------------------------------------------------------------------------- +# OPTION: -labelmargin +# +# Set the margin of the most adjacent side of the label to the hull +# relief. +# ---------------------------------------------------------------------------- +itcl::configbody iwidgets::Labeledframe::labelmargin { + _positionLabel +} + +# ----------------------------------------------------------------------------- +# OPTION: -labelpos +# +# Set the position of the label within the relief of the hull frame +# widget. +# ---------------------------------------------------------------------------- +itcl::configbody iwidgets::Labeledframe::labelpos { + _positionLabel +} + +# ----------------------------------------------------------------------------- +# PROCS +# ----------------------------------------------------------------------------- + +# ----------------------------------------------------------------------------- +# PRIVATE PROC: _initTable +# +# Initializes the _LAYOUT_TABLE common variable of the Labeledframe +# class. The initialization is performed in its own proc ( as opposed +# to in the class definition ) so that the initialization occurs only +# once. +# +# _LAYOUT_TABLE common array description: +# Provides a table of the configuration option values +# used to place the label widget within the grooved relief of the hull +# frame for each of the 12 possible "-labelpos" values. +# +# Each of the 12 rows is layed out as follows: +# {"-relx" "-rely" <rowconfigure|columnconfigure> <row/column number>} +# ----------------------------------------------------------------------------- +itcl::body iwidgets::Labeledframe::_initTable {} { + array set _LAYOUT_TABLE { + nw-relx 0.0 nw-rely 0.0 nw-wrap 0 nw-conf rowconfigure nw-num 0 + n-relx 0.5 n-rely 0.0 n-wrap 0 n-conf rowconfigure n-num 0 + ne-relx 1.0 ne-rely 0.0 ne-wrap 0 ne-conf rowconfigure ne-num 0 + + sw-relx 0.0 sw-rely 1.0 sw-wrap 0 sw-conf rowconfigure sw-num 2 + s-relx 0.5 s-rely 1.0 s-wrap 0 s-conf rowconfigure s-num 2 + se-relx 1.0 se-rely 1.0 se-wrap 0 se-conf rowconfigure se-num 2 + + en-relx 1.0 en-rely 0.0 en-wrap 1 en-conf columnconfigure en-num 2 + e-relx 1.0 e-rely 0.5 e-wrap 1 e-conf columnconfigure e-num 2 + es-relx 1.0 es-rely 1.0 es-wrap 1 es-conf columnconfigure es-num 2 + + wn-relx 0.0 wn-rely 0.0 wn-wrap 1 wn-conf columnconfigure wn-num 0 + w-relx 0.0 w-rely 0.5 w-wrap 1 w-conf columnconfigure w-num 0 + ws-relx 0.0 ws-rely 1.0 ws-wrap 1 ws-conf columnconfigure ws-num 0 + } + + # + # Since this is a one time only thing, we'll redefine the proc to be empty + # afterwards so it only happens once. + # + # NOTE: Be careful to use the "body" command, or the proc will get lost! + # + itcl::body ::iwidgets::Labeledframe::_initTable {} {} +} + +# ----------------------------------------------------------------------------- +# METHODS +# ----------------------------------------------------------------------------- + +# ----------------------------------------------------------------------------- +# PUBLIC METHOD:: childsite +# +# ----------------------------------------------------------------------------- +itcl::body iwidgets::Labeledframe::childsite {} { + return $itk_component(childsite) +} + +# ----------------------------------------------------------------------------- +# PROTECTED METHOD: _positionLabel ?when? +# +# Places the label in the relief of the hull. If "when" is "now", the +# change is applied immediately. If it is "later" or it is not +# specified, then the change is applied later, when the application +# is idle. +# ----------------------------------------------------------------------------- +itcl::body iwidgets::Labeledframe::_positionLabel {{when later}} { + + if {$when == "later"} { + if {$_reposition == ""} { + set _reposition [after idle [itcl::code $this _positionLabel now]] + } + return + } + + set pos $itk_option(-labelpos) + + # + # If there is not an entry for the "relx" value associated with + # the given "-labelpos" option value, then it invalid. + # + if { [catch {set relx $_LAYOUT_TABLE($pos-relx)}] } { + error "bad labelpos option\"$itk_option(-labelpos)\": should be\ + nw, n, ne, sw, s, se, en, e, es, wn, w, or ws" + } + + update idletasks + $itk_component(label) configure -wraplength $_LAYOUT_TABLE($pos-wrap) + set labelWidth [winfo reqwidth $itk_component(label)] + set labelHeight [winfo reqheight $itk_component(label)] + set borderwidth $itk_option(-borderwidth) + set margin $itk_option(-labelmargin) + + switch $pos { + nw { + set labelThickness $labelHeight + set minsize [expr {$labelThickness/2.0}] + set xPos [expr {$minsize+$borderwidth+$margin}] + set yPos -$minsize + } + n { + set labelThickness $labelHeight + set minsize [expr {$labelThickness/2.0}] + set xPos [expr {-$labelWidth/2.0}] + set yPos -$minsize + } + ne { + set labelThickness $labelHeight + set minsize [expr {$labelThickness/2.0}] + set xPos [expr {-($minsize+$borderwidth+$margin+$labelWidth)}] + set yPos -$minsize + } + + sw { + set labelThickness $labelHeight + set minsize [expr {$labelThickness/2.0}] + set xPos [expr {$minsize+$borderwidth+$margin}] + set yPos -$minsize + } + s { + set labelThickness $labelHeight + set minsize [expr {$labelThickness/2.0}] + set xPos [expr {-$labelWidth/2.0}] + set yPos [expr {-$labelHeight/2.0}] + } + se { + set labelThickness $labelHeight + set minsize [expr {$labelThickness/2.0}] + set xPos [expr {-($minsize+$borderwidth+$margin+$labelWidth)}] + set yPos [expr {-$labelHeight/2.0}] + } + + wn { + set labelThickness $labelWidth + set minsize [expr {$labelThickness/2.0}] + set xPos -$minsize + set yPos [expr {$minsize+$margin+$borderwidth}] + } + w { + set labelThickness $labelWidth + set minsize [expr {$labelThickness/2.0}] + set xPos -$minsize + set yPos [expr {-($labelHeight/2.0)}] + } + ws { + set labelThickness $labelWidth + set minsize [expr {$labelThickness/2.0}] + set xPos -$minsize + set yPos [expr {-($minsize+$borderwidth+$margin+$labelHeight)}] + } + + en { + set labelThickness $labelWidth + set minsize [expr {$labelThickness/2.0}] + set xPos -$minsize + set yPos [expr {$minsize+$borderwidth+$margin}] + } + e { + set labelThickness $labelWidth + set minsize [expr {$labelThickness/2.0}] + set xPos -$minsize + set yPos [expr {-($labelHeight/2.0)}] + } + es { + set labelThickness $labelWidth + set minsize [expr {$labelThickness/2.0}] + set xPos -$minsize + set yPos [expr {-($minsize+$borderwidth+$margin+$labelHeight)}] + } + } + _setMarginThickness $minsize + + place $itk_component(label) \ + -relx $_LAYOUT_TABLE($pos-relx) -x $xPos \ + -rely $_LAYOUT_TABLE($pos-rely) -y $yPos \ + -anchor nw + + set what $_LAYOUT_TABLE($pos-conf) + set number $_LAYOUT_TABLE($pos-num) + + grid $what $itk_interior $number -minsize $minsize + + set _reposition "" +} + +# ----------------------------------------------------------------------------- +# PROTECTED METHOD: _collapseMargin +# +# Resets the "-minsize" of all rows and columns of the hull's grid +# used to set the label margin to 0 +# ----------------------------------------------------------------------------- +itcl::body iwidgets::Labeledframe::_collapseMargin {} { + grid columnconfigure $itk_interior 0 -minsize 0 + grid columnconfigure $itk_interior 2 -minsize 0 + grid rowconfigure $itk_interior 0 -minsize 0 + grid rowconfigure $itk_interior 2 -minsize 0 +} + +# ----------------------------------------------------------------------------- +# PROTECTED METHOD: _setMarginThickness +# +# Set the margin thickness ( i.e. the hidden "-highlightthickness" +# of the hull ) to the input value. +# +# The "-highlightthickness" option of the hull frame is not intended to be +# configured by users of this class, but does need to be configured to properly +# place the label whenever the label is configured. +# +# Therefore, since I can't find a better way at this time, I achieve this +# configuration by: adding the "-highlightthickness" option back into +# the hull frame; configuring the "-highlightthickness" option to properly +# place the label; and then remove the "-highlightthickness" option from the +# hull. +# +# This way the option is not visible or configurable without some hacking. +# +# ----------------------------------------------------------------------------- +itcl::body iwidgets::Labeledframe::_setMarginThickness {value} { + itk_option add hull.highlightthickness + $itk_component(hull) configure -highlightthickness $value + itk_option remove hull.highlightthickness +} + + |