You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
1263 lines
34 KiB
1263 lines
34 KiB
# 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. |
|
|
|
package require Tcl 8.5 9 |
|
|
|
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.6
|
|
|