diff options
Diffstat (limited to 'tcllib/modules/counter/counter.tcl')
| -rw-r--r-- | tcllib/modules/counter/counter.tcl | 1265 |
1 files changed, 1265 insertions, 0 deletions
diff --git a/tcllib/modules/counter/counter.tcl b/tcllib/modules/counter/counter.tcl new file mode 100644 index 0000000..61aa3ff --- /dev/null +++ b/tcllib/modules/counter/counter.tcl @@ -0,0 +1,1265 @@ +# counter.tcl -- +# +# Procedures to manage simple counters and histograms. +# +# Copyright (c) 1998-2000 by Ajuba Solutions. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: counter.tcl,v 1.23 2005/09/30 05:36:38 andreas_kupries Exp $ + +package require Tcl 8.2 + +namespace eval ::counter { + + # Variables of name counter::T-$tagname + # are created as arrays to support each counter. + + # Time-based histograms are kept in sync with each other, + # so these variables are shared among them. + # These base times record the time corresponding to the first bucket + # of the per-minute, per-hour, and per-day time-based histograms. + + variable startTime + variable minuteBase + variable hourBase + variable hourEnd + variable dayBase + variable hourIndex + variable dayIndex + + # The time-based histogram uses an after event and a list + # of counters to do mergeing on. + + variable tagsToMerge + if {![info exists tagsToMerge]} { + set tagsToMerge {} + } + variable mergeInterval + + namespace export init reset count exists get names start stop + namespace export histHtmlDisplay histHtmlDisplayRow histHtmlDisplayBarChart +} + +# ::counter::init -- +# +# Set up a counter. +# +# Arguments: +# tag The identifier for the counter. Pass this to counter::count +# args option values pairs that define characteristics of the counter: +# See the man page for definitons. +# +# Results: +# None. +# +# Side Effects: +# Initializes state about a counter. + +proc ::counter::init {tag args} { + upvar #0 counter::T-$tag counter + if {[info exists counter]} { + unset counter + } + set counter(N) 0 ;# Number of samples + set counter(total) 0 + set counter(type) {} + + # With an empty type the counter is a simple accumulator + # for which we can compute an average. Here we loop through + # the args to determine what additional counter attributes + # we need to maintain in counter::count + + foreach {option value} $args { + switch -- $option { + -timehist { + variable tagsToMerge + variable secsPerMinute + variable startTime + variable minuteBase + variable hourBase + variable dayBase + variable hourIndex + variable dayIndex + + upvar #0 counter::H-$tag histogram + upvar #0 counter::Hour-$tag hourhist + upvar #0 counter::Day-$tag dayhist + + # Clear the histograms. + + for {set i 0} {$i < 60} {incr i} { + set histogram($i) 0 + } + for {set i 0} {$i < 24} {incr i} { + set hourhist($i) 0 + } + if {[info exists dayhist]} { + unset dayhist + } + set dayhist(0) 0 + + # Clear all-time high records + + set counter(maxPerMinute) 0 + set counter(maxPerHour) 0 + set counter(maxPerDay) 0 + + # The value associated with -timehist is the number of seconds + # in each bucket. Normally this is 60, but for + # testing, we compress minutes. The value is limited at + # 60 because the per-minute buckets are accumulated into + # per-hour buckets later. + + if {$value == "" || $value == 0 || $value > 60} { + set value 60 + } + + # Histogram state variables. + # All time-base histograms share the same bucket size + # and starting times to keep them all synchronized. + # So, we only initialize these parameters once. + + if {![info exists secsPerMinute]} { + set secsPerMinute $value + + set startTime [clock seconds] + set dayIndex 0 + + set dayStart [clock scan [clock format $startTime \ + -format 00:00]] + + # Figure out what "hour" we are + + set delta [expr {$startTime - $dayStart}] + set hourIndex [expr {$delta / ($secsPerMinute * 60)}] + set day [expr {$hourIndex / 24}] + set hourIndex [expr {$hourIndex % 24}] + + set hourBase [expr {$dayStart + $day * $secsPerMinute * 60 * 24}] + set minuteBase [expr {$hourBase + $hourIndex * 60 * $secsPerMinute}] + + set partialHour [expr {$startTime - + ($hourBase + $hourIndex * 60 * $secsPerMinute)}] + set secs [expr {(60 * $secsPerMinute) - $partialHour}] + if {$secs <= 0} { + set secs 1 + } + + # After the first timer, the event occurs once each "hour" + + set mergeInterval [expr {60 * $secsPerMinute * 1000}] + after [expr {$secs * 1000}] [list counter::MergeHour $mergeInterval] + } + if {[lsearch $tagsToMerge $tag] < 0} { + lappend tagsToMerge $tag + } + + # This records the last used slots in order to zero-out the + # buckets that are skipped during idle periods. + + set counter(lastMinute) -1 + + # The following is referenced when bugs cause histogram + # hits outside the expect range (overflow and underflow) + + set counter(bucketsize) 0 + } + -group { + # Cluster a set of counters with a single total + + upvar #0 counter::H-$tag histogram + if {[info exists histogram]} { + unset histogram + } + set counter(group) $value + } + -lastn { + # The lastN samples are kept if a vector to form a running average. + + upvar #0 counter::V-$tag vector + set counter(lastn) $value + set counter(index) 0 + if {[info exists vector]} { + unset vector + } + for {set i 0} {$i < $value} {incr i} { + set vector($i) 0 + } + } + -hist { + # A value-based histogram with buckets for different values. + + upvar #0 counter::H-$tag histogram + if {[info exists histogram]} { + unset histogram + } + set counter(bucketsize) $value + set counter(mult) 1 + } + -hist2x { + upvar #0 counter::H-$tag histogram + if {[info exists histogram]} { + unset histogram + } + set counter(bucketsize) $value + set counter(mult) 2 + } + -hist10x { + upvar #0 counter::H-$tag histogram + if {[info exists histogram]} { + unset histogram + } + set counter(bucketsize) $value + set counter(mult) 10 + } + -histlog { + upvar #0 counter::H-$tag histogram + if {[info exists histogram]} { + unset histogram + } + set counter(bucketsize) $value + } + -simple { + # Useful when disabling predefined -timehist or -group counter + } + default { + return -code error "Unsupported option $option.\ + Must be -timehist, -group, -lastn, -hist, -hist2x, -hist10x, -histlog, or -simple." + } + } + if {[string length $option]} { + # In case an option doesn't change the type, but + # this feature of the interface isn't used, etc. + + lappend counter(type) $option + } + } + + # Instead of supporting a counter that could have multiple attributes, + # we support a single type to make counting more efficient. + + if {[llength $counter(type)] > 1} { + return -code error "Multiple type attributes not supported. Use only one of\ + -timehist, -group, -lastn, -hist, -hist2x, -hist10x, -histlog, -disabled." + } + return "" +} + +# ::counter::reset -- +# +# Reset a counter. +# +# Arguments: +# tag The identifier for the counter. +# +# Results: +# None. +# +# Side Effects: +# Deletes the counter and calls counter::init again for it. + +proc ::counter::reset {tag args} { + upvar #0 counter::T-$tag counter + + # Layer reset on top of init. Here we figure out what + # we need to pass into the init procedure to recreate it. + + switch -- $counter(type) { + "" { + set args "" + } + -group { + upvar #0 counter::H-$tag histogram + if {[info exists histogram]} { + unset histogram + } + set args [list -group $counter(group)] + } + -lastn { + upvar #0 counter::V-$tag vector + if {[info exists vector]} { + unset vector + } + set args [list -lastn $counter(lastn)] + } + -hist - + -hist10x - + -histlog - + -hist2x { + upvar #0 counter::H-$tag histogram + if {[info exists histogram]} { + unset histogram + } + set args [list $counter(type) $counter(bucketsize)] + } + -timehist { + foreach h [list counter::H-$tag counter::Hour-$tag counter::Day-$tag] { + upvar #0 $h histogram + if {[info exists histogram]} { + unset histogram + } + } + set args [list -timehist $counter::secsPerMinute] + } + default {#ignore} + } + unset counter + eval {counter::init $tag} $args + set counter(resetDate) [clock seconds] + return "" +} + +# ::counter::count -- +# +# Accumulate statistics. +# +# Arguments: +# tag The counter identifier. +# delta The increment amount. Defaults to 1. +# arg For -group types, this is the histogram index. +# +# Results: +# None +# +# Side Effects: +# Accumlate statistics. + +proc ::counter::count {tag {delta 1} args} { + upvar #0 counter::T-$tag counter + set counter(total) [expr {$counter(total) + $delta}] + incr counter(N) + + # Instead of supporting a counter that could have multiple attributes, + # we support a single type to make counting a skosh more efficient. + +# foreach option $counter(type) { + switch -- $counter(type) { + "" { + # Simple counter + return + } + -group { + upvar #0 counter::H-$tag histogram + set subIndex [lindex $args 0] + if {![info exists histogram($subIndex)]} { + set histogram($subIndex) 0 + } + set histogram($subIndex) [expr {$histogram($subIndex) + $delta}] + } + -lastn { + upvar #0 counter::V-$tag vector + set vector($counter(index)) $delta + set counter(index) [expr {($counter(index) +1)%$counter(lastn)}] + } + -hist { + upvar #0 counter::H-$tag histogram + set bucket [expr {int($delta / $counter(bucketsize))}] + if {![info exists histogram($bucket)]} { + set histogram($bucket) 0 + } + incr histogram($bucket) + } + -hist10x - + -hist2x { + upvar #0 counter::H-$tag histogram + set bucket 0 + for {set max $counter(bucketsize)} {$delta > $max} \ + {set max [expr {$max * $counter(mult)}]} { + incr bucket + } + if {![info exists histogram($bucket)]} { + set histogram($bucket) 0 + } + incr histogram($bucket) + } + -histlog { + upvar #0 counter::H-$tag histogram + set bucket [expr {int(log($delta)*$counter(bucketsize))}] + if {![info exists histogram($bucket)]} { + set histogram($bucket) 0 + } + incr histogram($bucket) + } + -timehist { + upvar #0 counter::H-$tag histogram + variable minuteBase + variable secsPerMinute + + set minute [expr {([clock seconds] - $minuteBase) / $secsPerMinute}] + if {$minute > 59} { + # this occurs while debugging if the process is + # stopped at a breakpoint too long. + set minute 59 + } + + # Initialize the current bucket and + # clear any buckets we've skipped since the last sample. + + if {$minute != $counter(lastMinute)} { + set histogram($minute) 0 + for {set i [expr {$counter(lastMinute)+1}]} \ + {$i < $minute} \ + {incr i} { + set histogram($i) 0 + } + set counter(lastMinute) $minute + } + set histogram($minute) [expr {$histogram($minute) + $delta}] + } + default {#ignore} + } +# } + return +} + +# ::counter::exists -- +# +# Return true if the counter exists. +# +# Arguments: +# tag The counter identifier. +# +# Results: +# 1 if it has been defined. +# +# Side Effects: +# None. + +proc ::counter::exists {tag} { + upvar #0 counter::T-$tag counter + return [info exists counter] +} + +# ::counter::get -- +# +# Return statistics. +# +# Arguments: +# tag The counter identifier. +# option What statistic to get +# args Needed by some options. +# +# Results: +# With no args, just the counter value. +# +# Side Effects: +# None. + +proc ::counter::get {tag {option -total} args} { + upvar #0 counter::T-$tag counter + switch -- $option { + -total { + return $counter(total) + } + -totalVar { + return ::counter::T-$tag\(total) + } + -N { + return $counter(N) + } + -avg { + if {$counter(N) == 0} { + return 0 + } else { + return [expr {$counter(total) / double($counter(N))}] + } + } + -avgn { + if {$counter(type) != "-lastn"} { + return -code error "The -avgn option is only supported for -lastn counters." + } + upvar #0 counter::V-$tag vector + set sum 0 + for {set i 0} {($i < $counter(N)) && ($i < $counter(lastn))} {incr i} { + set sum [expr {$sum + $vector($i)}] + } + if {$i == 0} { + return 0 + } else { + return [expr {$sum / double($i)}] + } + } + -hist { + upvar #0 counter::H-$tag histogram + if {[llength $args]} { + # Return particular bucket + set bucket [lindex $args 0] + if {[info exists histogram($bucket)]} { + return $histogram($bucket) + } else { + return 0 + } + } else { + # Dump the whole histogram + + set result {} + if {$counter(type) == "-group"} { + set sort -dictionary + } else { + set sort -integer + } + foreach x [lsort $sort [array names histogram]] { + lappend result $x $histogram($x) + } + return $result + } + } + -histVar { + return ::counter::H-$tag + } + -histHour { + upvar #0 counter::Hour-$tag histogram + set result {} + foreach x [lsort -integer [array names histogram]] { + lappend result $x $histogram($x) + } + return $result + } + -histHourVar { + return ::counter::Hour-$tag + } + -histDay { + upvar #0 counter::Day-$tag histogram + set result {} + foreach x [lsort -integer [array names histogram]] { + lappend result $x $histogram($x) + } + return $result + } + -histDayVar { + return ::counter::Day-$tag + } + -maxPerMinute { + return $counter(maxPerMinute) + } + -maxPerHour { + return $counter(maxPerHour) + } + -maxPerDay { + return $counter(maxPerDay) + } + -resetDate { + if {[info exists counter(resetDate)]} { + return $counter(resetDate) + } else { + return "" + } + } + -all { + return [array get counter] + } + default { + return -code error "Invalid option $option.\ + Should be -all, -total, -N, -avg, -avgn, -hist, -histHour,\ + -histDay, -totalVar, -histVar, -histHourVar, -histDayVar -resetDate." + } + } +} + +# ::counter::names -- +# +# Return the list of defined counters. +# +# Arguments: +# none +# +# Results: +# A list of counter tags. +# +# Side Effects: +# None. + +proc ::counter::names {} { + set result {} + foreach v [info vars ::counter::T-*] { + if {[info exists $v]} { + # Declared arrays might not exist, yet + # strip prefix from name + set v [string range $v [string length "::counter::T-"] end] + lappend result $v + } + } + return $result +} + +# ::counter::MergeHour -- +# +# Sum the per-minute histogram into the next hourly bucket. +# On 24-hour boundaries, sum the hourly buckets into the next day bucket. +# This operates on all time-based histograms. +# +# Arguments: +# none +# +# Results: +# none +# +# Side Effects: +# See description. + +proc ::counter::MergeHour {interval} { + variable hourIndex + variable minuteBase + variable hourBase + variable tagsToMerge + variable secsPerMinute + + after $interval [list counter::MergeHour $interval] + if {![info exists hourBase] || $hourIndex == 0} { + set hourBase $minuteBase + } + set minuteBase [clock seconds] + + foreach tag $tagsToMerge { + upvar #0 counter::T-$tag counter + upvar #0 counter::H-$tag histogram + upvar #0 counter::Hour-$tag hourhist + + # Clear any buckets we've skipped since the last sample. + + for {set i [expr {$counter(lastMinute)+1}]} {$i < 60} {incr i} { + set histogram($i) 0 + } + set counter(lastMinute) -1 + + # Accumulate into the next hour bucket. + + set hourhist($hourIndex) 0 + set max 0 + foreach i [array names histogram] { + set hourhist($hourIndex) [expr {$hourhist($hourIndex) + $histogram($i)}] + if {$histogram($i) > $max} { + set max $histogram($i) + } + } + set perSec [expr {$max / $secsPerMinute}] + if {$perSec > $counter(maxPerMinute)} { + set counter(maxPerMinute) $perSec + } + } + set hourIndex [expr {($hourIndex + 1) % 24}] + if {$hourIndex == 0} { + counter::MergeDay + } + +} +# ::counter::MergeDay -- +# +# Sum the per-minute histogram into the next hourly bucket. +# On 24-hour boundaries, sum the hourly buckets into the next day bucket. +# This operates on all time-based histograms. +# +# Arguments: +# none +# +# Results: +# none +# +# Side Effects: +# See description. + +proc ::counter::MergeDay {} { + variable dayIndex + variable dayBase + variable hourBase + variable tagsToMerge + variable secsPerMinute + + # Save the hours histogram into a bucket for the last day + # counter(day,$day) is the starting time for that day bucket + + if {![info exists dayBase]} { + set dayBase $hourBase + } + foreach tag $tagsToMerge { + upvar #0 counter::T-$tag counter + upvar #0 counter::Day-$tag dayhist + upvar #0 counter::Hour-$tag hourhist + set dayhist($dayIndex) 0 + set max 0 + for {set i 0} {$i < 24} {incr i} { + if {[info exists hourhist($i)]} { + set dayhist($dayIndex) [expr {$dayhist($dayIndex) + $hourhist($i)}] + if {$hourhist($i) > $max} { + set max $hourhist($i) + } + } + } + set perSec [expr {double($max) / ($secsPerMinute * 60)}] + if {$perSec > $counter(maxPerHour)} { + set counter(maxPerHour) $perSec + } + } + set perSec [expr {double($dayhist($dayIndex)) / ($secsPerMinute * 60 * 24)}] + if {$perSec > $counter(maxPerDay)} { + set counter(maxPerDay) $perSec + } + incr dayIndex +} + +# ::counter::histHtmlDisplay -- +# +# Create an html display of the histogram. +# +# Arguments: +# tag The counter tag +# args option, value pairs that affect the display: +# -title Label to display above bar chart +# -unit minutes, hours, or days select time-base histograms. +# Specify anything else for value-based histograms. +# -images URL of /images directory. +# -gif Image for normal histogram bars +# -ongif Image for the active histogram bar +# -max Maximum number of value-based buckets to display +# -height Pixel height of the highest bar +# -width Pixel width of each bar +# -skip Buckets to skip when labeling value-based histograms +# -format Format used to display labels of buckets. +# -text If 1, a text version of the histogram is dumped, +# otherwise a graphical one is generated. +# +# Results: +# HTML for the display as a complete table. +# +# Side Effects: +# None. + +proc ::counter::histHtmlDisplay {tag args} { + append result "<p>\n<table border=0 cellpadding=0 cellspacing=0>\n" + append result [eval {counter::histHtmlDisplayRow $tag} $args] + append result </table> + return $result +} + +# ::counter::histHtmlDisplayRow -- +# +# Create an html display of the histogram. +# +# Arguments: +# See counter::histHtmlDisplay +# +# Results: +# HTML for the display. Ths is one row of a 2-column table, +# the calling page must define the <table> tag. +# +# Side Effects: +# None. + +proc ::counter::histHtmlDisplayRow {tag args} { + upvar #0 counter::T-$tag counter + variable secsPerMinute + variable minuteBase + variable hourBase + variable dayBase + variable hourIndex + variable dayIndex + + array set options [list \ + -title $tag \ + -unit "" \ + -images /images \ + -gif Blue.gif \ + -ongif Red.gif \ + -max -1 \ + -height 100 \ + -width 4 \ + -skip 4 \ + -format %.2f \ + -text 0 + ] + array set options $args + + # Support for self-posting pages that can clear counters. + + append result "<!-- resetCounter [ncgi::value resetCounter] -->" + if {[ncgi::value resetCounter] == $tag} { + counter::reset $tag + return "<!-- Reset $tag counter -->" + } + + switch -glob -- $options(-unit) { + min* { + upvar #0 counter::H-$tag histogram + set histname counter::H-$tag + if {![info exists minuteBase]} { + return "<!-- No time-based histograms defined -->" + } + set time $minuteBase + set secsForMax $secsPerMinute + set periodMax $counter(maxPerMinute) + set curIndex [expr {([clock seconds] - $minuteBase) / $secsPerMinute}] + set options(-max) 60 + set options(-min) 0 + } + hour* { + upvar #0 counter::Hour-$tag histogram + set histname counter::Hour-$tag + if {![info exists hourBase]} { + return "<!-- Hour merge has not occurred -->" + } + set time $hourBase + set secsForMax [expr {$secsPerMinute * 60}] + set periodMax $counter(maxPerHour) + set curIndex [expr {$hourIndex - 1}] + if {$curIndex < 0} { + set curIndex 23 + } + set options(-max) 24 + set options(-min) 0 + } + day* { + upvar #0 counter::Day-$tag histogram + set histname counter::Day-$tag + if {![info exists dayBase]} { + return "<!-- Hour merge has not occurred -->" + } + set time $dayBase + set secsForMax [expr {$secsPerMinute * 60 * 24}] + set periodMax $counter(maxPerDay) + set curIndex dayIndex + set options(-max) $dayIndex + set options(-min) 0 + } + default { + # Value-based histogram with arbitrary units. + + upvar #0 counter::H-$tag histogram + set histname counter::H-$tag + + set unit $options(-unit) + set curIndex "" + set time "" + } + } + if {! [info exists histogram]} { + return "<!-- $histname doesn't exist -->\n" + } + + set max 0 + set maxName 0 + foreach {name value} [array get histogram] { + if {$value > $max} { + set max $value + set maxName $name + } + } + + # Start 2-column HTML display. A summary table at the left, the histogram on the right. + + append result "<tr><td valign=top>\n" + + append result "<table bgcolor=#EEEEEE>\n" + append result "<tr><td colspan=2 align=center>[html::font]<b>$options(-title)</b></font></td></tr>\n" + append result "<tr><td>[html::font]<b>Total</b></font></td>" + append result "<td>[html::font][format $options(-format) $counter(total)]</font></td></tr>\n" + + if {[info exists secsForMax]} { + + # Time-base histogram + + set string {} + set t $secsForMax + set days [expr {$t / (60 * 60 * 24)}] + if {$days == 1} { + append string "1 Day " + } elseif {$days > 1} { + append string "$days Days " + } + set t [expr {$t - $days * (60 * 60 * 24)}] + set hours [expr {$t / (60 * 60)}] + if {$hours == 1} { + append string "1 Hour " + } elseif {$hours > 1} { + append string "$hours Hours " + } + set t [expr {$t - $hours * (60 * 60)}] + set mins [expr {$t / 60}] + if {$mins == 1} { + append string "1 Minute " + } elseif {$mins > 1} { + append string "$mins Minutes " + } + set t [expr {$t - $mins * 60}] + if {$t == 1} { + append string "1 Second " + } elseif {$t > 1} { + append string "$t Seconds " + } + append result "<tr><td>[html::font]<b>Bucket Size</b></font></td>" + append result "<td>[html::font]$string</font></td></tr>\n" + + append result "<tr><td>[html::font]<b>Max Per Sec</b></font></td>" + append result "<td>[html::font][format %.2f [expr {$max/double($secsForMax)}]]</font></td></tr>\n" + + if {$periodMax > 0} { + append result "<tr><td>[html::font]<b>Best Per Sec</b></font></td>" + append result "<td>[html::font][format %.2f $periodMax]</font></td></tr>\n" + } + append result "<tr><td>[html::font]<b>Starting Time</b></font></td>" + switch -glob -- $options(-unit) { + min* { + append result "<td>[html::font][clock format $time \ + -format %k:%M:%S]</font></td></tr>\n" + } + hour* { + append result "<td>[html::font][clock format $time \ + -format %k:%M:%S]</font></td></tr>\n" + } + day* { + append result "<td>[html::font][clock format $time \ + -format "%b %d %k:%M"]</font></td></tr>\n" + } + default {#ignore} + } + + } else { + + # Value-base histogram + + set ix [lsort -integer [array names histogram]] + + set mode [expr {$counter(bucketsize) * $maxName}] + set first [expr {$counter(bucketsize) * [lindex $ix 0]}] + set last [expr {$counter(bucketsize) * [lindex $ix end]}] + + append result "<tr><td>[html::font]<b>Average</b></font></td>" + append result "<td>[html::font][format $options(-format) [counter::get $tag -avg]]</font></td></tr>\n" + + append result "<tr><td>[html::font]<b>Mode</b></font></td>" + append result "<td>[html::font]$mode</font></td></tr>\n" + + append result "<tr><td>[html::font]<b>Minimum</b></font></td>" + append result "<td>[html::font]$first</font></td></tr>\n" + + append result "<tr><td>[html::font]<b>Maximum</b></font></td>" + append result "<td>[html::font]$last</font></td></tr>\n" + + append result "<tr><td>[html::font]<b>Unit</b></font></td>" + append result "<td>[html::font]$unit</font></td></tr>\n" + + append result "<tr><td colspan=2 align=center>[html::font]<b>" + append result "<a href=[ncgi::urlStub]?resetCounter=$tag>Reset</a></td></tr>\n" + + if {$options(-max) < 0} { + set options(-max) [lindex $ix end] + } + if {![info exists options(-min)]} { + set options(-min) [lindex $ix 0] + } + } + + # End table nested inside left-hand column + + append result </table>\n + append result </td>\n + append result "<td valign=bottom>\n" + + + # Display the histogram + + if {$options(-text)} { + } else { + append result [eval \ + {counter::histHtmlDisplayBarChart $tag histogram $max $curIndex $time} \ + [array get options]] + } + + # Close the right hand column, but leave our caller's table open. + + append result </td></tr>\n + + return $result +} + +# ::counter::histHtmlDisplayBarChart -- +# +# Create an html display of the histogram. +# +# Arguments: +# tag The counter tag. +# histVar The name of the histogram array +# max The maximum counter value in a histogram bucket. +# curIndex The "current" histogram index, for time-base histograms. +# time The base, or starting time, for the time-based histograms. +# args The array get of the options passed into histHtmlDisplay +# +# Results: +# HTML for the bar chart. +# +# Side Effects: +# See description. + +proc ::counter::histHtmlDisplayBarChart {tag histVar max curIndex time args} { + upvar #0 counter::T-$tag counter + upvar 1 $histVar histogram + variable secsPerMinute + array set options $args + + append result "<table cellpadding=0 cellspacing=0 bgcolor=#eeeeee><tr>\n" + + set ix [lsort -integer [array names histogram]] + + for {set t $options(-min)} {$t < $options(-max)} {incr t} { + if {![info exists histogram($t)]} { + set value 0 + } else { + set value $histogram($t) + } + if {$max == 0 || $value == 0} { + set height 1 + } else { + set percent [expr {round($value * 100.0 / $max)}] + set height [expr {$percent * $options(-height) / 100}] + } + if {$t == $curIndex} { + set img src=$options(-images)/$options(-ongif) + } else { + set img src=$options(-images)/$options(-gif) + } + append result "<td valign=bottom><img $img height=$height\ + width=$options(-width) title=$value alt=$value></td>\n" + } + append result "</tr>" + + # Count buckets outside the range requested + + set overflow 0 + set underflow 0 + foreach t [lsort -integer [array names histogram]] { + if {($options(-max) > 0) && ($t > $options(-max))} { + incr overflow + } + if {($options(-min) >= 0) && ($t < $options(-min))} { + incr underflow + } + } + + # Append a row of labels at the bottom. + + set colors {black #CCCCCC} + set bgcolors {#CCCCCC black} + set colori 0 + if {$counter(type) != "-timehist"} { + + # Label each bucket with its value + # This is probably wrong for hist2x and hist10x + + append result "<tr>" + set skip $options(-skip) + if {![info exists counter(mult)]} { + set counter(mult) 1 + } + + # These are tick marks + + set img src=$options(-images)/$options(-gif) + append result "<tr>" + for {set i $options(-min)} {$i < $options(-max)} {incr i} { + if {(($i % $skip) == 0)} { + append result "<td valign=bottom><img $img height=3 \ + width=1></td>\n" + } else { + append result "<td valign=bottom></td>" + } + } + append result </tr> + + # These are the labels + + append result "<tr>" + for {set i $options(-min)} {$i < $options(-max)} {incr i} { + if {$counter(type) == "-histlog"} { + if {[catch {expr {int(log($i) * $counter(bucketsize))}} x]} { + # Out-of-bounds + break + } + } else { + set x [expr {$i * $counter(bucketsize) * $counter(mult)}] + } + set label [format $options(-format) $x] + if {(($i % $skip) == 0)} { + set color [lindex $colors $colori] + set bg [lindex $bgcolors $colori] + set colori [expr {($colori+1) % 2}] + append result "<td colspan=$skip><font size=1 color=$color>$label</font></td>" + } + } + append result </tr> + } else { + switch -glob -- $options(-unit) { + min* { + if {$secsPerMinute != 60} { + set format %k:%M:%S + set skip 12 + } else { + set format %k:%M + set skip 4 + } + set deltaT $secsPerMinute + set wrapDeltaT [expr {$secsPerMinute * -59}] + } + hour* { + if {$secsPerMinute != 60} { + set format %k:%M + set skip 4 + } else { + set format %k + set skip 2 + } + set deltaT [expr {$secsPerMinute * 60}] + set wrapDeltaT [expr {$secsPerMinute * 60 * -23}] + } + day* { + if {$secsPerMinute != 60} { + set format "%m/%d %k:%M" + set skip 10 + } else { + set format %k + set skip $options(-skip) + } + set deltaT [expr {$secsPerMinute * 60 * 24}] + set wrapDeltaT 0 + } + default {#ignore} + } + # These are tick marks + + set img src=$options(-images)/$options(-gif) + append result "<tr>" + foreach t [lsort -integer [array names histogram]] { + if {(($t % $skip) == 0)} { + append result "<td valign=bottom><img $img height=3 \ + width=1></td>\n" + } else { + append result "<td valign=bottom></td>" + } + } + append result </tr> + + set lastLabel "" + append result "<tr>" + foreach t [lsort -integer [array names histogram]] { + + # Label each bucket with its time + + set label [clock format $time -format $format] + if {(($t % $skip) == 0) && ($label != $lastLabel)} { + set color [lindex $colors $colori] + set bg [lindex $bgcolors $colori] + set colori [expr {($colori+1) % 2}] + append result "<td colspan=$skip><font size=1 color=$color>$label</font></td>" + set lastLabel $label + } + if {$t == $curIndex} { + incr time $wrapDeltaT + } else { + incr time $deltaT + } + } + append result </tr>\n + } + append result "</table>" + if {$underflow > 0} { + append result "<br>Skipped $underflow samples <\ + [expr {$options(-min) * $counter(bucketsize)}]\n" + } + if {$overflow > 0} { + append result "<br>Skipped $overflow samples >\ + [expr {$options(-max) * $counter(bucketsize)}]\n" + } + return $result +} + +# ::counter::start -- +# +# Start an interval timer. This should be pre-declared with +# type either -hist, -hist2x, or -hist20x +# +# Arguments: +# tag The counter identifier. +# instance There may be multiple intervals outstanding +# at any time. This serves to distinquish them. +# +# Results: +# None +# +# Side Effects: +# Records the starting time for the instance of this interval. + +proc ::counter::start {tag instance} { + upvar #0 counter::Time-$tag time + # clock clicks can return negative values if the sign bit is set + # Here we turn it into a 31-bit counter because we only want + # relative differences + set msec [expr {[clock clicks -milliseconds] & 0x7FFFFFFF}] + set time($instance) [list $msec [clock seconds]] +} + +# ::counter::stop -- +# +# Record an interval timer. +# +# Arguments: +# tag The counter identifier. +# instance There may be multiple intervals outstanding +# at any time. This serves to distinquish them. +# func An optional function used to massage the time +# stamp before putting into the histogram. +# +# Results: +# None +# +# Side Effects: +# Computes the current interval and adds it to the histogram. + +proc ::counter::stop {tag instance {func ::counter::Identity}} { + upvar #0 counter::Time-$tag time + + if {![info exists time($instance)]} { + # Extra call. Ignore so we can debug error cases. + return + } + set msec [expr {[clock clicks -milliseconds] & 0x7FFFFFFF}] + set now [list $msec [clock seconds]] + set delMicros [expr {[lindex $now 0] - [lindex $time($instance) 0]}] + if {$delMicros < 0} { + # Microsecond counter wrapped. + set delMicros [expr {0x7FFFFFFF - [lindex $time($instance) 0] + + [lindex $now 0]}] + } + set delSecond [expr {[lindex $now 1] - [lindex $time($instance) 1]}] + unset time($instance) + + # It is quite possible that the millisecond counter is much + # larger than 1000, so we just use it unless our microsecond + # calculation is screwed up. + + if {$delMicros >= 0} { + counter::count $tag [$func [expr {$delMicros / 1000.0}]] + } else { + counter::count $tag [$func $delSecond] + } +} + +# ::counter::Identity -- +# +# Return its argument. This is used as the default function +# to apply to an interval timer. +# +# Arguments: +# x Some value. +# +# Results: +# $x +# +# Side Effects: +# None + + +proc ::counter::Identity {x} { + return $x +} + +package provide counter 2.0.4 |