share/redhat/gui/wframe.tcl

# wframe.tcl - Frame with a widget on its border.
# Copyright (C) 1997 Cygnus Solutions.
# Written by Tom Tromey <tromey@cygnus.com>.

itcl_class Widgetframe {
  # Where to put the widget.  For now, we don't support many anchors.
  # Augment as you like.
  public anchor nw {
    if {$anchor != "nw" && $anchor != "n"} then {
      error "anchors nw and n are the only ones supported"
    }
    _layout
  }

  # The name of the widget to put on the frame.  This is set by some
  # subclass calling the _add method.  Private variable.
  protected _widget {}

  constructor {config} {
    # The standard widget-making trick.
    set class [$this info class]
    set hull [namespace tail $this]
    set old_name $this
    ::rename $this $this-tmp-
    ::frame $hull -class $class -relief flat -borderwidth 0
    ::rename $hull $old_name-win-
    ::rename $this $old_name

    frame [namespace tail $this].iframe -relief groove -borderwidth 2
    grid [namespace tail $this].iframe -row 1 -sticky news
    grid rowconfigure  [namespace tail $this] 1 -weight 1
    grid columnconfigure  [namespace tail $this] 0 -weight 1

    # Make an internal frame so that user stuff isn't obscured.  Note
    # that we can't use the placer, because it doesn't set the
    # geometry of the parent.
    frame [namespace tail $this].iframe.frame -borderwidth 4 -relief flat
    grid [namespace tail $this].iframe.frame -row 1 -sticky news
    grid rowconfigure [namespace tail $this].iframe 1 -weight 1
    grid columnconfigure [namespace tail $this].iframe 0 -weight 1

    bind [namespace tail $this].iframe <Destroy> [list $this delete]
  }

  destructor {
    catch {destroy $this}
  }

  # Return name of internal frame.
  method get_frame {} {
    return [namespace tail $this].iframe.frame
  }

  # Name a certain widget to be put on the frame.  This should be
  # called by some subclass after making the widget.  Protected
  # method.
  method _add {widget} {
    set _widget $widget
    set height [expr {int ([winfo reqheight $_widget] / 2)}]
    grid rowconfigure  [namespace tail $this] 0 -minsize $height -weight 0
    grid rowconfigure [namespace tail $this].iframe 0 -minsize $height -weight 0
    _layout
  }

  # Re-layout according to the anchor.  Private method.
  method _layout {} {
    if {$_widget == "" || ! [winfo exists $_widget]} then {
      return
    }

    switch -- $anchor {
      n {
	# Put the label over the border, in the center.
	place $_widget -in [namespace tail $this].iframe -relx 0.5 -rely 0 -y -2 \
	  -anchor center
      }
      nw {
	# Put the label over the border, at the top left.
	place $_widget -in [namespace tail $this].iframe -relx 0 -x 6 -rely 0 -y -2 \
	  -anchor w
      }
      default {
	error "unsupported anchor \"$anchor\""
      }
    }
  }
}