progressbar1.wgt

一个跨平台的TCL/TK可视开发环境类似VC. TCL/TK是一个跨平台的脚本语言.

      set opt [Canonize $w option [lindex $args 0]]
      set result $options($opt)
    }

    configure {
      set result [eval Configure {$w} $args]
    }

    incr -
    step {
      set val 1
      if {[llength $args] > 1} {
      	return -code error "wrong # args: should be $w $command <incrValue>"
      } elseif {[llength $args] == 1} {
      	set val $args
      }
      set percent [$w cget -percent]
      set result [eval Configure $w -percent [expr $percent + $val]]
    }

    default {
	return -code error "bad option \"$command\": must be cget or configure"
    }
  }
  return $result
}


# ::progressbar::HumanizeList --
#
#    Returns a human-readable form of a list by separating items
#    by columns, but separating the last two elements with "or"
#    (eg: foo, bar or baz)
#
# Arguments:
#
#    list    a valid tcl list
#
# Results:
#
#    A string which as all of the elements joined with ", " or 
#    the word " or "

proc ::progressbar::HumanizeList {list} {
  variable widgetGlobals

  if {$widgetGlobals(debug)} {
    puts stderr "pb_HumanizeList $list"
  }

  if {[llength $list] == 1} {
    return [lindex $list 0]
  } else {
    set list [lsort $list]
    set secondToLast [expr {[llength $list] -2}]
    set most [lrange $list 0 $secondToLast]
    set last [lindex $list end]

    return "[join $most {, }] or $last"
  }
}


# ::progressbar::Canonize --
#
#    takes a (possibly abbreviated) option or command name and either 
#    returns the canonical name or an error
#
# Arguments:
#
#    w        widget pathname
#    object   type of object to canonize; must be one of "command",
#             "option", "column" or "column option".
#    opt      the option (or command) to be canonized
#
# Returns:
#
#    Returns either the canonical form of an option or command,
#    or raises an error if the option or command is unknown or
#    ambiguous.

proc ::progressbar::Canonize {w object opt} {
  variable widgetOptions
  variable widgetCommands
  variable widgetGlobals
  variable widgetShapes

  if {$widgetGlobals(debug)} {
    puts stderr "pb_Canonize '$w' '$object' '$opt'"
  }

  switch $object {
    command {
      if {[lsearch -exact $widgetCommands $opt] >= 0} {
	return $opt
      }

      # command names aren't stored in an array, and there
      # isn't a way to get all the matches in a list, so
      # we'll stuff the columns in a temporary array so
      # we can use [array names]
      set list $widgetCommands
      foreach element $list {
	set tmp($element) ""
      }
      set matches [array names tmp ${opt}*]
    }

    option {
      if {[info exists widgetOptions($opt)] \
	  && [llength $widgetOptions($opt)] == 3} {
	return $opt
      }
      set list [array names widgetOptions]
      set matches [array names widgetOptions ${opt}*]
    }

    shape {
      if {[lsearch -exact $widgetShapes $opt] >= 0} {
	return $opt
      }

      # same procedure as command
      set list $widgetShapes
      foreach element $list {
	set tmp($element) ""
      }
      set matches [array names tmp ${opt}*]
    }
  }
  if {[llength $matches] == 0} {
    set choices [HumanizeList $list]
    return -code error "unknown $object \"$opt\"; must be one of $choices"
  } elseif {[llength $matches] == 1} {
    # deal with option aliases
    set opt [lindex $matches 0]
    switch $object {
      option {
	if {[llength $widgetOptions($opt)] == 1} {
	  set opt $widgetOptions($opt)
	}
      }
    }
    return $opt
  } else {
      set choices [HumanizeList $list]
      return -code error "ambiguous $object \"$opt\"; must be one of $choices"
  }
}


# ::progressbar::RGBs --
#
#    Calculates RGB colors
#
# Arguments:
#
#    color  basic color as rgb or name
#
# Returns:
#    
#    A list of 6 calculated RGBs values and the original value.
 
proc ::progressbar::RGBs {color} {
  variable widgetGlobals

  if {$widgetGlobals(debug)} {
    puts stderr "pb_RGB '$color'"
  }

  # get rgb values of given color
  set color [winfo rgb . $color]

  set R [expr int([lindex $color 0] / 256)]
  set G [expr int([lindex $color 1] / 256)]
  set B [expr int([lindex $color 2] / 256)]

  set rgb {}
  foreach factor {0.13 0.32 0.45 0.68 0.8 0.93} {
    set r [expr int($R * $factor)]
    set g [expr int($G * $factor)]
    set b [expr int($B * $factor)]
    lappend rgb [format "#%02x%02x%02x" $r $g $b]
  }
  lappend rgb [format "#%02x%02x%02x" $R $G $B]

  return $rgb
}


# ::progressbar::Configure --
#
#    Implements the "configure" widget subcommand
#
# Arguments:
#
#    w      widget pathname
#    args   zero or more option/value pairs (or a single option)
#
# Results:
#    
#    Performs typcial "configure" type requests on the widget
 
proc ::progressbar::Configure {w args} {
  variable widgetOptions
  variable widgetGlobals

  if {$widgetGlobals(debug)} {
    puts stderr "pb_Configure '$w' '$args'"
  }

  upvar ${w}::widgets widgets
  upvar ${w}::options options
  upvar ${w}::info info
  
  if {[llength $args] == 0} {
    # hmmm. User must be wanting all configuration information
    # note that if the value of an array element is of length
    # one it is an alias, which needs to be handled slightly
    # differently
    set results {}
    foreach opt [lsort [array names widgetOptions]] {
      if {[llength $widgetOptions($opt)] == 1} {
	set alias $widgetOptions($opt)
	set optName $widgetOptions($alias)
	lappend results [list $opt $optName]
      } else {
	set optName  [lindex $widgetOptions($opt) 0]
	set optClass [lindex $widgetOptions($opt) 1]
	set default [option get $w $optName $optClass]
	lappend results [list $opt $optName $optClass $default $options($opt)]
      }
    }
    return $results
  }
  
  # one argument means we are looking for configuration
  # information on a single option
  if {[llength $args] == 1} {
    set opt [Canonize $w option [lindex $args 0]]
    set optName  [lindex $widgetOptions($opt) 0]
    set optClass [lindex $widgetOptions($opt) 1]
    set default [option get $w $optName $optClass]
    set results [list $opt $optName $optClass $default $options($opt)]
    return $results
  }

  # if we have an odd number of values, bail. 
  if {[expr {[llength $args]%2}] == 1} {
    # hmmm. An odd number of elements in args
    return -code error "value for \"[lindex $args end]\" missing"
  }
  
  # Great. An even number of options. Let's make sure they 
  # are all valid before we do anything. Note that Canonize
  # will generate an error if it finds a bogus option; otherwise
  # it returns the canonical option name
  foreach {name value} $args {
    set name [Canonize $w option $name]
    set opts($name) $value
  }

  # process all of the configuration options
  foreach option [array names opts] {
    set newValue $opts($option)
    if {[info exists options($option)]} {
      set oldValue $options($option)
    }

    if {$widgetGlobals(debug) > 2} {
      puts stderr "pb_Configure:Opt '$option' n='$newValue' o='$oldValue'"
    }
    switch -- $option {
      -background  -
      -borderwidth -
      -relief      {
	if {[winfo exists $widgets(this)]} {
	  $widgets(frame) configure $option $newValue
	  set options($option) [$widgets(frame) cget $option]
	}
      }
      -color {
        switch -- $newValue {
	  @blue0    -
	  @blue1    -
	  @blue2    -
	  @blue3    -
	  @blue4    -
	  @green0   -
	  @green1   -
	  @green2   -
	  @green3   -
	  @yellow0  -
	  @yellow1  -
	  @red0     -
	  @red1     -
	  @magenta0 -
	  @brown0   -
	  @brown1   -
	  @gray0    {
	    set info(rgb) $widgetGlobals($newValue)
	  }
	  @* {
	    set info(rgb) $widgetGlobals(@saphir)
	  }
	  default {
	    set info(rgb) [RGBs $newValue]
	  }
	}
	set info(rgbHasChanged) 1
      }
      -percent {
	set options($option) $newValue
      }
      -shape {
	set options($option) [Canonize $w shape $newValue]
	set info(rgbHasChanged) 1
      }
      -variable {
	# hmmm .. are there any traces left? Yes! Destroy!
	if {[info procs Trace($w)] != ""} {
	  uplevel #0 trace vdelete $oldValue wu ::progressbar::Trace($w)
	  unset widgetGlobals($w)
	  rename Trace($w) {}
	}
	if {$newValue != ""} {
	  # there is a new variable to trace. build a new proc to trace it.
	  proc ::progressbar::Trace($w) {name1 name2 op} "
	    variable widgetGlobals

	    if {\$widgetGlobals(debug)} {
	      puts stderr \"pb_Trace($w) '\$name1' '\$name2' '\$op'\"
	    }
	    switch -- \$op {
	      w {
		if {\$name2 != \"\"} {
		  upvar 1 \${name1}(\$name2) var
		  catch {$w configure -percent \$var}
		} else {
		  upvar 1 \$name1 var
		  catch {$w configure -percent \$var}
		}
	      }
	      u {
		if {\[info procs Trace($w)\] != \"\"} { \
		  unset widgetGlobals($w); \
		  rename Trace($w) {}; \
		}
	      }
	    }
	  "
	  # install trace proc for variable
	  uplevel #0 trace variable $newValue wu ::progressbar::Trace($w)
	}
	set options($option) $newValue
	set widgetGlobals($w) $newValue
      }
      -width {
	if {$newValue < 20} {
	  return -code error "a -width of less than 20 is not supported."
	}
	if {[winfo exists $widgets(canvas)]} {
	  $widgets(canvas) configure $option $newValue
	  set options($option) [$widgets(canvas) cget $option]
	} else {
          set options($option) $newValue
	}
      }
      -textvalue {
        set options($option) $newValue
	if {![winfo exists $widgets(canvas)]} { continue }
	$widgets(canvas) itemconfigure ttxt -text $newValue
      }
      -textcolor {
        set options($option) $newValue
	if {![winfo exists $widgets(canvas)]} { continue }
	$widgets(canvas) itemconfigure ttxt -fill $newValue
      }
    }
  }

  Draw $w
}


# ::progressbar::DestroyHandler {w} --
# 
#    Cleans up after a progressbar widget is destroyed
#
# Arguments:
#
#    w    widget pathname
#
# Results:
#
#    The namespace that was created for the widget is deleted,
#    the widget proc and variable traces are removed.

proc ::progressbar::DestroyHandler {w} {
  variable widgetGlobals

  if {$widgetGlobals(debug)} {
    puts stderr "pb_DestroyHandler '$w'"
  }

  # hmmm .. are there any traces left? Yes! Destroy!
  if {[info procs Trace($w)] != ""} {
    uplevel 1 trace vdelete $widgetGlobals($w) wu ::progressbar::Trace($w)
    unset widgetGlobals($w)
    rename Trace($w) {}
  }

  # if the widget actually being destroyed is of class Progressbar,
  # crush the namespace and kill the proc. Get it? Crush. Kill. 
  # Destroy. Heh. Danger Will Robinson! Oh, man! I'm so funny it
  # brings tears to my eyes.
  if {[string compare [winfo class $w] "Progressbar1"] == 0} {
    namespace delete ::progressbar::$w
    rename $w {}
  }
}


# ::progressbar::Draw --
#
#    Implements the draw subroutine
#
# Arguments:
#
#    w      widget pathname
#
# Results:
#    
#    Performs the drawing of progressbar

proc ::progressbar::Draw {w} {
  variable widgetGlobals

  if {$widgetGlobals(debug) > 2} {
    puts stderr "pb_Draw '$w'"
  }

  upvar ${w}::widgets widgets
  upvar ${w}::options options
  upvar ${w}::info info

  set width   $options(-width)
  set percent $options(-percent)
  set text    $options(-textvalue)

  if {$options(-shape) == "flat"} {
    set minDisplay 0
    if {[llength $info(rgb)] == 7} {
      set rgb(0) [lindex $info(rgb) 6]
    } else {
      set rgb(0) [lindex $info(rgb) 2]
    }
    set rgb(1) $rgb(0)
    set rgb(2) $rgb(0)
    set rgb(3) $rgb(0)
    set rgb(4) $rgb(0)
    set rgb(5) $rgb(0)
  } else {
    set minDisplay 7
    set rgb(0) [lindex $info(rgb) 0]
    set rgb(1) [lindex $info(rgb) 1]
    set rgb(2) [lindex $info(rgb) 2]
    set rgb(3) [lindex $info(rgb) 3]
    set rgb(4) [lindex $info(rgb) 4]
    set rgb(5) [lindex $info(rgb) 5]
  }

  if {$percent < 0} {
    set percent 0
  } elseif {$percent > 100} {
    set percent 100
  }
  if {$percent == 0} {
    set mark $minDisplay
  } else {
    set mark [expr (($width - $minDisplay) / 100.0 * $percent) + $minDisplay]
  }

  if {![winfo exists $widgets(canvas)]} {
    canvas $widgets(canvas) -width $width -height 14 -bd 0 -highlightthickness 0
    pack $widgets(canvas) -side left -anchor nw -fill both

    foreach {type color tag coords opts} $widgetGlobals(toDraw) {
      eval $widgets(canvas) create $type $coords -fill $color -tag t$tag $opts
    }

    set info(rgbHasChanged) 0
    # nothing more to do
    return
  }

  foreach {type color tag coords opts} $widgetGlobals(toDraw) {
    eval $widgets(canvas) coords t$tag $coords
    if {$info(rgbHasChanged)} {
      eval $widgets(canvas) itemconfigure t$tag -fill $color
    }
  }
  set info(rgbHasChanged) 0
}