Open Mash Cross Reference
mash/tcl/mb/ui-mb-option.tcl

   # ui-mb-option.tcl --
   #
   #       a customized menu similar to tk's option menu, but handles graphics and
   #       extensions
   #
   # Copyright (c) 1997-2002 The Regents of the University of California.
   # All rights reserved.
   #
   # Redistribution and use in source and binary forms, with or without
  # modification, are permitted provided that the following conditions are met:
  #
  # A. Redistributions of source code must retain the above copyright notice,
  #    this list of conditions and the following disclaimer.
  # B. Redistributions in binary form must reproduce the above copyright notice,
  #    this list of conditions and the following disclaimer in the documentation
  #    and/or other materials provided with the distribution.
  # C. Neither the names of the copyright holders nor the names of its
  #    contributors may be used to endorse or promote products derived from this
  #    software without specific prior written permission.
  #
  # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS IS''
  # AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
  # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  # ARE DISCLAIMED.  IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR
  # ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  # DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
  # SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
  # CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
  # OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
  # OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  
  Class MBOptionMenu
  
  MBOptionMenu instproc update {label value } {
      $self instvar varN_ labelN_ type_ menu_button_
      upvar #0 $varN_ v
      upvar #0 $labelN_ lv
  
      set v $value
      set lv $label
      case $type_ {
          "colors" {
              if {"$value" != ""} {
                  $menu_button_ configure \
                          -bg $value -activebackground $value -text "    "
              } else {
                  set bg [[winfo parent $menu_button_] cget -background]
                  $menu_button_ configure \
                          -bg $bg -activebackground $bg -text $label
              }
          }
          "font" {
              $menu_button_ configure -text "Abc" -font $value
          }
          default {
              $menu_button_ configure -text $value
          }
      }
  }
  
  MBOptionMenu instproc new_color {} {
          set newcolor [tk_chooseColor -title "Choose color"]
          if {$newcolor!=""} {
                  $self add_colors $newcolor $newcolor
                  $self update $$newcolor $newcolor
          }
  }
  
  MBOptionMenu instproc add_colors {label value} {
      $self instvar menu_ font_
  
      if {"$label" == "custom"} {
          $menu_ add command -label $label -font $font_ \
                  -command "$self new_color"
      } elseif {"$value" != ""} {
          $menu_ add command -label "    " -background $value \
                  -activebackground $value -font $font_ \
                  -command [list $self update $label $value]
      } else {
          $menu_ add command -label $label -font $font_ \
                  -command [list $self update $label $value]
      }
  }
  
  MBOptionMenu instproc add_text {label value} {
      $self instvar menu_ font_
  
      $menu_ add command -label $label -font $font_ \
              -command [list $self update $label $value]
  }
  
  MBOptionMenu instproc add_font {label value} {
      $self instvar menu_
  
      $menu_ add command -label "ABCabc" -font $value \
              -command [list $self update $label $value]
  }
  
  # format of props:
 # { typeoflist default index label1 value1 label2 value2 .... }
 MBOptionMenu instproc init {w varName labelName props} {
     upvar #0 $varName v
     upvar #0 $labelName lv
     $self instvar varN_ labelN_ menu_ menu_button_ type_
 
     set varN_ $varName
     set labelN_ $labelName
 
     $self instvar font_
     set font_ [$self get_option smallfont]
 
     set menu_button_ [menubutton $w \
             -indicatoron 0 -menu $w.menu -font $font_ \
             -relief raised -anchor c]
     set menu_ [menu $w.menu -tearoff 0]
 
     set type_ [lindex $props 0]
     set def [expr [lindex $props 1] * 2]
     set propslist [lrange $props 2 end]
 #    DbgOut "props=$propslist"
 
     foreach {label value} $propslist {
         $self add_$type_ $label $value
     }
     set lv [lindex $props $def]
     set v [lindex $props [expr $def + 1] ]
     $self update $lv $v
 }
 
 proc mb_image_optionMenu {w varName firstValue args} {
     global env
 
     upvar #0 $varName var
     set img [image create photo -format GIF -gamma 1]
     $img read "$env(MB_BITMAPS)/red.gif" -to 0 0
 
     if ![info exists var] {
         set var $firstValue
     }
     menubutton $w -textvariable $varName -indicatoron 1 -menu $w.menu \
             -relief raised -bd 2 -highlightthickness 2 -anchor c
     menu $w.menu -tearoff 0
     $w.menu add command -label $firstValue\
             -command [list set $varName $firstValue]
     foreach i $args {
         $w.menu add command -image $img -command [list set $varName $i]
     }
 }
 
 proc CollapseArgsList {l} {
 
     set final { }
 
     foreach i $l {
         set var   [lindex $i 0]
         set value [lindex $i 3]
         if {[string length $value] != 0} {
             set final [concat $final $var $value]
         }
     }
     DbgOut $final
     return $final
 }