/usr/share/tcltk/iwidgets4.0.1/scripts/labeledframe.itk

#
# 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
}
iwidgets4 4.0.1-5 / usr / share / tcltk / iwidgets4.0.1 / scripts / labeledframe.itk
