| # |
| # 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 |
| } |
| |
| |
