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.
497 lines
17 KiB
Plaintext
497 lines
17 KiB
Plaintext
#
|
|
# 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
|
|
}
|
|
|
|
|