share/iwidgets4.0.1/scripts/extbutton.itk

#-------------------------------------------------------------------------------
# Extbutton
#-------------------------------------------------------------------------------
# This [incr Widget] is pretty simple - it just extends the behavior of
# the Tk button by allowing the user to add a bitmap or an image, which
# can be placed at various locations relative to the text via the -imagepos
# configuration option.
#
#-------------------------------------------------------------------------------
# IMPORTANT NOTE: This [incr Widget] will only work with Tk 8.4 or later.
#
#-------------------------------------------------------------------------------
# AUTHOR:  Chad Smith               E-mail: csmith@adc.com, itclguy@yahoo.com
#-------------------------------------------------------------------------------
# Permission to use, copy, modify, distribute, and license this software
# and its documentation for any purpose is hereby granted as long as this
# comment block remains intact.
#-------------------------------------------------------------------------------

#
# Default resources
#
option add *Extbutton.borderwidth 2 widgetDefault
option add *Extbutton.relief raised widgetDefault

#
# Usual options
#
itk::usual Extbutton {
  keep -cursor -font
}

itcl::class iwidgets::Extbutton {
  inherit itk::Widget

  constructor {args} {}

  itk_option define -activebackground activeBackground Foreground #ececec
  itk_option define -bd borderwidth BorderWidth 2
  itk_option define -bitmap bitmap Bitmap {}
  itk_option define -command command Command {}
  itk_option define -defaultring defaultring DefaultRing 0
  itk_option define -defaultringpad defaultringpad Pad 4
  itk_option define -image image Image {}
  itk_option define -imagepos imagePos Position w
  itk_option define -relief relief Relief raised
  itk_option define -state state State normal
  itk_option define -text text Text {}

  public method invoke {} {eval $itk_option(-command)}
  public method flash {}

  private method changeColor {event_}
  private method sink {}
  private method raise {} {configure -relief $_oldValues(-relief)}

  private variable _oldValues
}


#
# Provide the usual lowercase access command.
#
proc iwidgets::extbutton {path_ args} {
  uplevel iwidgets::Extbutton $path_ $args
}


#-------------------------------------------------------------------------------
# OPTION: -bd
#
# DESCRIPTION: This isn't a new option.  Similar to -image, we just need to
#   repack the frame when the borderwidth changes.  This option is kept by
#   the private reliefframe component.
#-------------------------------------------------------------------------------
itcl::configbody iwidgets::Extbutton::bd {
  pack $itk_component(frame) -padx 4 -pady 4
}


#-------------------------------------------------------------------------------
# OPTION: -bitmap
#
# DESCRIPTION: This isn't a new option - we just need to reset the -image option
#   so that the user can toggle back and forth between images and bitmaps.
#   Otherwise, the image will take precedence and the user will be unable to
#   change to a bitmap without manually setting the label component's -image to
#   an empty string.  This option is kept by the image component.
#-------------------------------------------------------------------------------
itcl::configbody iwidgets::Extbutton::bitmap {
  if {$itk_option(-bitmap) == ""} {
    return
  }
  if {$itk_option(-image) != ""} {
    configure -image {}
  }
  pack $itk_component(frame) -padx 4 -pady 4
}


#-------------------------------------------------------------------------------
# OPTION: -command
#
# DESCRIPTION: Invoke the given command to simulate the Tk button's -command
#   option.  The command is invoked on <ButtonRelease-1> events only or by
#   direct calls to the public invoke() method.
#-------------------------------------------------------------------------------
itcl::configbody iwidgets::Extbutton::command {
  if {$itk_option(-command) == ""} {
    return
  }

  # Only create the tag binding if the button is operable.
  if {$itk_option(-state) == "normal"} {
    bind $this-commandtag <ButtonRelease-1> [itcl::code $this invoke]
  }

  # Associate the tag with each component if it's not already done.
  if {[lsearch [bindtags $itk_interior] $this-commandtag] == -1} {
    foreach component [component] {
      bindtags [component $component] \
        [linsert [bindtags [component $component]] end $this-commandtag]
    }
  }
}


#-------------------------------------------------------------------------------
# OPTION: -defaultring
#
# DESCRIPTION: Controls display of the sunken frame surrounding the button.
#   This option simulates the pushbutton iwidget -defaultring option.
#-------------------------------------------------------------------------------
itcl::configbody iwidgets::Extbutton::defaultring {
  switch -- $itk_option(-defaultring) {
    1 {set ring 1}
    0 {set ring 0}
    default {
      error "Invalid option for -defaultring: \"$itk_option(-defaultring)\".  \
             Should be 1 or 0."
    }
  }

  if ($ring) {
    $itk_component(ring) configure -borderwidth 2
    pack $itk_component(reliefframe) -padx $itk_option(-defaultringpad) \
      -pady $itk_option(-defaultringpad)
  } else {
    $itk_component(ring) configure -borderwidth 0
    pack $itk_component(reliefframe) -padx 0 -pady 0
  }
}


#-------------------------------------------------------------------------------
# OPTION: -defaultringpad
#
# DESCRIPTION: The pad distance between the ring and the button.
#-------------------------------------------------------------------------------
itcl::configbody iwidgets::Extbutton::defaultringpad {
  # Must be an integer.
  if ![string is integer $itk_option(-defaultringpad)] {
    error "Invalid value specified for -defaultringpad:\
	   \"$itk_option(-defaultringpad)\".  Must be an integer."
  }

  # Let's go ahead and make the maximum padding 20 pixels.  Surely no one
  # will want more than that.
  if {$itk_option(-defaultringpad) < 0 || $itk_option(-defaultringpad) > 20} {
    error "Value for -defaultringpad must be between 0 and 20."
  }

  # If the ring is displayed, repack it according to the new padding amount.
  if {$itk_option(-defaultring)} {
    pack $itk_component(reliefframe) -padx $itk_option(-defaultringpad) \
      -pady $itk_option(-defaultringpad)
  }
}


#-------------------------------------------------------------------------------
# OPTION: -image
#
# DESCRIPTION: This isn't a new option - we just need to repack the frame after
#   the image is changed in case the size is different than the previous one.
#   This option is kept by the image component.
#-------------------------------------------------------------------------------
itcl::configbody iwidgets::Extbutton::image {
  pack $itk_component(frame) -padx 4 -pady 4
}


#-------------------------------------------------------------------------------
# OPTION: -imagepos
#
# DESCRIPTION: Allows the user to move the image to different locations areound
#   the text.  Valid options are n, nw, ne, s, sw, se e, en, es, w, wn or ws.
#-------------------------------------------------------------------------------
itcl::configbody iwidgets::Extbutton::imagepos {
  switch -- $itk_option(-imagepos) {
    n  {set side top;    set anchor center}
    ne {set side top;    set anchor e}
    nw {set side top;    set anchor w}

    s  {set side bottom; set anchor center}
    se {set side bottom; set anchor e}
    sw {set side bottom; set anchor w}

    w  {set side left;   set anchor center}
    wn {set side left;   set anchor n}
    ws {set side left;   set anchor s}

    e  {set side right;  set anchor center}
    en {set side right;  set anchor n}
    es {set side right;  set anchor s}

    default {
      error "Invalid option: \"$itk_option(-imagepos)\". \
             Must be n, nw, ne, s, sw, se e, en, es, w, wn or ws."
    }
  }

  pack $itk_component(image) -side $side -anchor $anchor
  pack $itk_component(frame) -padx 4 -pady 4
}


#-------------------------------------------------------------------------------
# OPTION: -relief
#
# DESCRIPTION: Move the frame component according to the relief to simulate
#   the text in a Tk button when its relief is changed.
#-------------------------------------------------------------------------------
itcl::configbody iwidgets::Extbutton::relief {
  update idletasks
  switch -- $itk_option(-relief) {
    flat - ridge - groove {
      place $itk_component(frame) -x 5 -y 5
    }

    raised {
      place $itk_component(frame) -x 4 -y 4
    }

    sunken {
      place $itk_component(frame) -x 6 -y 6
    }

    default {
      error "Invalid option: \"$itk_option(-relief)\".  \
             Must be flat, ridge, groove, raised, or sunken."
    }
  }
}


#-------------------------------------------------------------------------------
# OPTION: -state
#
# DESCRIPTION: Simulate the button's -state option.
#-------------------------------------------------------------------------------
itcl::configbody iwidgets::Extbutton::state {
  switch -- $itk_option(-state) {
    disabled {
      bind $itk_interior <Enter> { }
      bind $itk_interior <Leave> { }
      bind $this-sunkentag <1> { }
      bind $this-raisedtag <ButtonRelease-1> { }
      bind $this-commandtag <ButtonRelease-1> { }
      set _oldValues(-fg) [cget -foreground]
      set _oldValues(-cursor) [cget -cursor]
      configure -foreground $itk_option(-disabledforeground)
      configure -cursor "X_cursor red black"
    }

    normal {
      bind $itk_interior <Enter> [itcl::code $this changeColor enter]
      bind $itk_interior <Leave> [itcl::code $this changeColor leave]
      bind $this-sunkentag <1> [itcl::code $this sink]
      bind $this-raisedtag <ButtonRelease-1> [itcl::code $this raise]
      bind $this-commandtag <ButtonRelease-1> [itcl::code $this invoke]
      configure -foreground $_oldValues(-fg)
      configure -cursor $_oldValues(-cursor)
    }

    default {
      error "Bad option for -state: \"$itk_option(-state)\".  Should be\
	normal or disabled."
    }
  }
}


#-------------------------------------------------------------------------------
# OPTION: -text
#
# DESCRIPTION: This isn't a new option.  Similar to -image, we just need to
#   repack the frame when the text changes.   
#-------------------------------------------------------------------------------
itcl::configbody iwidgets::Extbutton::text {
  pack $itk_component(frame) -padx 4 -pady 4
}



#-------------------------------------------------------------------------------
#                                CONSTRUCTOR
#-------------------------------------------------------------------------------
itcl::body iwidgets::Extbutton::constructor {args} {
  # Extbutton will not work with versions of Tk less than 8.4 (the
  # -activeforeground option was added to the Tk label widget in 8.4, for
  # example).  So disallow its use unless the right wish is being used.
  if {$::tk_version < 8.4} {
    error "The extbutton \[incr Widget\] can only be used with versions of\
      Tk greater than 8.3.\nYou're currently using version $::tk_version."
  }

  # This frame is optionally displayed as a "default ring" around the button.
  itk_component add ring {
    frame $itk_interior.ring -relief sunken
  } {
    rename -background -ringbackground ringBackground Background
  }

  # Add an outer frame for the widget's relief.  Ideally we could just keep
  # the hull's -relief, but it's too tricky to handle relief changes.
  itk_component add -private reliefframe {
    frame $itk_component(ring).f
  } {
    rename -borderwidth -bd borderwidth BorderWidth
    keep -relief
    usual
  }

  # This frame contains the image and text.  It will be moved slightly to
  # simulate the text in a Tk button when the button is depressed/raised.
  itk_component add frame {
    frame $itk_component(reliefframe).f -borderwidth 0
  }

  itk_component add image {
    label $itk_component(frame).img -borderwidth 0
  } {
    keep -bitmap -background -image
    rename -foreground -bitmapforeground foreground Foreground
  }

  itk_component add label {
    label $itk_component(frame).txt -borderwidth 0
  } {
    keep -activeforeground -background -disabledforeground
    keep -font -foreground -justify -text
  }

  pack $itk_component(image) $itk_component(label) -side left -padx 6 -pady 4
  pack $itk_component(frame) -padx 4 -pady 4
  pack $itk_component(reliefframe) -fill both
  pack $itk_component(ring) -fill both

  # Create a couple of binding tags for handling relief changes.  Then
  # add these tags to each component.
  foreach component [component] {
    bindtags [component $component] \
      [linsert [bindtags [component $component]] end $this-sunkentag]
    bindtags [component $component] \
      [linsert [bindtags [component $component]] end $this-raisedtag]
  }

  set _oldValues(-fg) [cget -foreground]
  set _oldValues(-cursor) [cget -cursor]

  eval itk_initialize $args
}


#-------------------------------------------------------------------------------
# METHOD: flash
#
# ACCESS: public
#
# DESCRIPTION: Simulate the Tk button flash command.
#
# ARGUMENTS: none
#-------------------------------------------------------------------------------
itcl::body iwidgets::Extbutton::flash {} {
  set oldbg [cget -background]
  config -background $itk_option(-activebackground)
  update idletasks

  after 50; config -background $oldbg; update idletasks
  after 50; config -background $itk_option(-activebackground); update idletasks
  after 50; config -background $oldbg
}


#-------------------------------------------------------------------------------
# METHOD: changeColor
#
# ACCESS: private
#
# DESCRIPTION: This method is invoked by <Enter> and <Leave> events to change
#   the background and foreground colors of the widget.
#
# ARGUMENTS: event_ --> either "enter" or "leave"
#-------------------------------------------------------------------------------
itcl::body iwidgets::Extbutton::changeColor {event_} {
  switch -- $event_ {
    enter {
      set _oldValues(-bg) [cget -background]
      set _oldValues(-fg) [cget -foreground]
      configure -background $itk_option(-activebackground)
      configure -foreground $itk_option(-activeforeground)
    }
    leave {
      configure -background $_oldValues(-bg)
      configure -foreground $_oldValues(-fg)
    }
  }
}


#-------------------------------------------------------------------------------
# METHOD: sink
#
# ACCESS: private
#
# DESCRIPTION: This method is invoked on <1> mouse events.  It saves the
#   current relief for later restoral and configures the relief to sunken if
#   it isn't already sunken.
#
# ARGUMENTS: none
#-------------------------------------------------------------------------------
itcl::body iwidgets::Extbutton::sink {} {
  set _oldValues(-relief) [cget -relief]
  if {$_oldValues(-relief) == "sunken"} {
    return
  }
  configure -relief sunken
}