source: tol/tolsh/tolsh.vfs/lib/tcllib1.10/counter/counter.tcl @ 8597867d

1941-docker-image-to-testdevel
Last change on this file since 8597867d was 8597867d, checked in by Jorge Pérez <josp.jorge@…>, 16 years ago

closes #976, se incluye tcllib1.10, base64 debe eliminarse del raiz de lib ya que esta incluido en tcllib

git-svn-id: ​https://www.tol-project.org/svn/tolp/trunk@2556 be4846ae-f051-483a-831f-b64e7d08527f
  • Property mode set to 100644
File size: 34.4 KB
Line 
1# counter.tcl --
2#
3#   Procedures to manage simple counters and histograms.
4#
5# Copyright (c) 1998-2000 by Ajuba Solutions.
6#
7# See the file "license.terms" for information on usage and redistribution
8# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
9#
10# RCS: @(#) $Id: counter.tcl,v 1.23 2005/09/30 05:36:38 andreas_kupries Exp $
11
12package require Tcl 8.2
13
14namespace eval ::counter {
15
16    # Variables of name counter::T-$tagname
17    # are created as arrays to support each counter.
18
19    # Time-based histograms are kept in sync with each other,
20    # so these variables are shared among them.
21    # These base times record the time corresponding to the first bucket
22    # of the per-minute, per-hour, and per-day time-based histograms.
23
24    variable startTime
25    variable minuteBase
26    variable hourBase
27    variable hourEnd
28    variable dayBase
29    variable hourIndex
30    variable dayIndex
31
32    # The time-based histogram uses an after event and a list
33    # of counters to do mergeing on.
34
35    variable tagsToMerge
36    if {![info exists tagsToMerge]} {
37    set tagsToMerge {}
38    }
39    variable mergeInterval
40
41    namespace export init reset count exists get names start stop
42    namespace export histHtmlDisplay histHtmlDisplayRow histHtmlDisplayBarChart
43}
44
45# ::counter::init --
46#
47#   Set up a counter.
48#
49# Arguments:
50#   tag The identifier for the counter.  Pass this to counter::count
51#   args    option values pairs that define characteristics of the counter:
52#       See the man page for definitons.
53#
54# Results:
55#   None.
56#
57# Side Effects:
58#   Initializes state about a counter.
59
60proc ::counter::init {tag args} {
61    upvar #0 counter::T-$tag counter
62    if {[info exists counter]} {
63    unset counter
64    }
65    set counter(N) 0    ;# Number of samples
66    set counter(total) 0
67    set counter(type) {}
68
69    # With an empty type the counter is a simple accumulator
70    # for which we can compute an average.  Here we loop through
71    # the args to determine what additional counter attributes
72    # we need to maintain in counter::count
73
74    foreach {option value} $args {
75    switch -- $option {
76        -timehist {
77        variable tagsToMerge
78        variable secsPerMinute
79        variable startTime
80        variable minuteBase
81        variable hourBase
82        variable dayBase
83        variable hourIndex
84        variable dayIndex
85
86        upvar #0 counter::H-$tag histogram
87        upvar #0 counter::Hour-$tag hourhist
88        upvar #0 counter::Day-$tag dayhist
89
90        # Clear the histograms.
91
92        for {set i 0} {$i < 60} {incr i} {
93            set histogram($i) 0
94        }
95        for {set i 0} {$i < 24} {incr i} {
96            set hourhist($i) 0
97        }
98        if {[info exists dayhist]} {
99            unset dayhist
100        }
101        set dayhist(0) 0
102
103        # Clear all-time high records
104
105        set counter(maxPerMinute) 0
106        set counter(maxPerHour) 0
107        set counter(maxPerDay) 0
108
109        # The value associated with -timehist is the number of seconds
110        # in each bucket.  Normally this is 60, but for
111        # testing, we compress minutes.  The value is limited at
112        # 60 because the per-minute buckets are accumulated into
113        # per-hour buckets later.
114
115        if {$value == "" || $value == 0 || $value > 60} {
116            set value 60
117        }
118
119        # Histogram state variables.
120        # All time-base histograms share the same bucket size
121        # and starting times to keep them all synchronized.
122        # So, we only initialize these parameters once.
123
124        if {![info exists secsPerMinute]} {
125            set secsPerMinute $value
126
127            set startTime [clock seconds]
128            set dayIndex 0
129
130            set dayStart [clock scan [clock format $startTime \
131                -format 00:00]]
132           
133            # Figure out what "hour" we are
134
135            set delta [expr {$startTime - $dayStart}]
136            set hourIndex [expr {$delta / ($secsPerMinute * 60)}]
137            set day [expr {$hourIndex / 24}]
138            set hourIndex [expr {$hourIndex % 24}]
139
140            set hourBase [expr {$dayStart + $day * $secsPerMinute * 60 * 24}]
141            set minuteBase [expr {$hourBase + $hourIndex * 60 * $secsPerMinute}]
142
143            set partialHour [expr {$startTime -
144            ($hourBase + $hourIndex * 60 * $secsPerMinute)}]
145            set secs [expr {(60 * $secsPerMinute) - $partialHour}]
146            if {$secs <= 0} {
147            set secs 1
148            }
149
150            # After the first timer, the event occurs once each "hour"
151
152            set mergeInterval [expr {60 * $secsPerMinute * 1000}]
153            after [expr {$secs * 1000}] [list counter::MergeHour $mergeInterval]
154        }
155        if {[lsearch $tagsToMerge $tag] < 0} {
156            lappend tagsToMerge $tag
157        }
158
159        # This records the last used slots in order to zero-out the
160        # buckets that are skipped during idle periods.
161
162        set counter(lastMinute) -1
163
164        # The following is referenced when bugs cause histogram
165        # hits outside the expect range (overflow and underflow)
166
167        set counter(bucketsize)  0
168        }
169        -group {
170        # Cluster a set of counters with a single total
171
172        upvar #0 counter::H-$tag histogram
173        if {[info exists histogram]} {
174            unset histogram
175        }
176        set counter(group) $value
177        }
178        -lastn {
179        # The lastN samples are kept if a vector to form a running average.
180
181        upvar #0 counter::V-$tag vector
182        set counter(lastn) $value
183        set counter(index) 0
184        if {[info exists vector]} {
185            unset vector
186        }
187        for {set i 0} {$i < $value} {incr i} {
188            set vector($i) 0
189        }
190        }
191        -hist {
192        # A value-based histogram with buckets for different values.
193
194        upvar #0 counter::H-$tag histogram
195        if {[info exists histogram]} {
196            unset histogram
197        }
198        set counter(bucketsize) $value
199        set counter(mult) 1
200        }
201        -hist2x {
202        upvar #0 counter::H-$tag histogram
203        if {[info exists histogram]} {
204            unset histogram
205        }
206        set counter(bucketsize) $value
207        set counter(mult) 2
208        }
209        -hist10x {
210        upvar #0 counter::H-$tag histogram
211        if {[info exists histogram]} {
212            unset histogram
213        }
214        set counter(bucketsize) $value
215        set counter(mult) 10
216        }
217        -histlog {
218        upvar #0 counter::H-$tag histogram
219        if {[info exists histogram]} {
220            unset histogram
221        }
222        set counter(bucketsize) $value
223        }
224        -simple {
225        # Useful when disabling predefined -timehist or -group counter
226        }
227        default {
228        return -code error "Unsupported option $option.\
229        Must be -timehist, -group, -lastn, -hist, -hist2x, -hist10x, -histlog, or -simple."
230        }
231    }
232    if {[string length $option]} {
233        # In case an option doesn't change the type, but
234        # this feature of the interface isn't used, etc.
235
236        lappend counter(type) $option
237    }
238    }
239
240    # Instead of supporting a counter that could have multiple attributes,
241    # we support a single type to make counting more efficient.
242
243    if {[llength $counter(type)] > 1} {
244    return -code error "Multiple type attributes not supported.  Use only one of\
245        -timehist, -group, -lastn, -hist, -hist2x, -hist10x, -histlog, -disabled."
246    }
247    return ""
248}
249
250# ::counter::reset --
251#
252#   Reset a counter.
253#
254# Arguments:
255#   tag The identifier for the counter.
256#
257# Results:
258#   None.
259#
260# Side Effects:
261#   Deletes the counter and calls counter::init again for it.
262
263proc ::counter::reset {tag args} {
264    upvar #0 counter::T-$tag counter
265
266    # Layer reset on top of init.  Here we figure out what
267    # we need to pass into the init procedure to recreate it.
268
269    switch -- $counter(type) {
270    ""  {
271        set args ""
272    }
273    -group {
274        upvar #0 counter::H-$tag histogram
275        if {[info exists histogram]} {
276        unset histogram
277        }
278        set args [list -group $counter(group)]
279    }
280    -lastn {
281        upvar #0 counter::V-$tag vector
282        if {[info exists vector]} {
283        unset vector
284        }
285        set args [list -lastn $counter(lastn)]
286    }
287    -hist -
288    -hist10x -
289    -histlog -
290    -hist2x {
291        upvar #0 counter::H-$tag histogram
292        if {[info exists histogram]} {
293        unset histogram
294        }
295        set args [list $counter(type) $counter(bucketsize)]
296    }
297    -timehist {
298        foreach h [list counter::H-$tag counter::Hour-$tag counter::Day-$tag] {
299        upvar #0 $h histogram
300        if {[info exists histogram]} {
301            unset histogram
302        }
303        }
304        set args [list -timehist $counter::secsPerMinute]
305    }
306    default {#ignore}
307    }
308    unset counter
309    eval {counter::init $tag} $args
310    set counter(resetDate) [clock seconds]
311    return ""
312}
313
314# ::counter::count --
315#
316#   Accumulate statistics.
317#
318# Arguments:
319#   tag The counter identifier.
320#   delta   The increment amount.  Defaults to 1.
321#   arg For -group types, this is the histogram index.
322#
323# Results:
324#   None
325#
326# Side Effects:
327#   Accumlate statistics.
328
329proc ::counter::count {tag {delta 1} args} {
330    upvar #0 counter::T-$tag counter
331    set counter(total) [expr {$counter(total) + $delta}]
332    incr counter(N)
333
334    # Instead of supporting a counter that could have multiple attributes,
335    # we support a single type to make counting a skosh more efficient.
336
337#    foreach option $counter(type) {
338    switch -- $counter(type) {
339        ""  {
340        # Simple counter
341        return
342        }
343        -group {
344        upvar #0 counter::H-$tag histogram
345        set subIndex [lindex $args 0]
346        if {![info exists histogram($subIndex)]} {
347            set histogram($subIndex) 0
348        }
349        set histogram($subIndex) [expr {$histogram($subIndex) + $delta}]
350        }
351        -lastn {
352        upvar #0 counter::V-$tag vector
353        set vector($counter(index)) $delta
354        set counter(index) [expr {($counter(index) +1)%$counter(lastn)}]
355        }
356        -hist {
357        upvar #0 counter::H-$tag histogram
358        set bucket [expr {int($delta / $counter(bucketsize))}]
359        if {![info exists histogram($bucket)]} {
360            set histogram($bucket) 0
361        }
362        incr histogram($bucket)
363        }
364        -hist10x -
365        -hist2x {
366        upvar #0 counter::H-$tag histogram
367        set bucket 0
368        for {set max $counter(bucketsize)} {$delta > $max} \
369            {set max [expr {$max * $counter(mult)}]} {
370            incr bucket
371        }
372        if {![info exists histogram($bucket)]} {
373            set histogram($bucket) 0
374        }
375        incr histogram($bucket)
376        }
377        -histlog {
378        upvar #0 counter::H-$tag histogram
379        set bucket [expr {int(log($delta)*$counter(bucketsize))}]
380        if {![info exists histogram($bucket)]} {
381            set histogram($bucket) 0
382        }
383        incr histogram($bucket)
384        }
385        -timehist {
386        upvar #0 counter::H-$tag histogram
387        variable minuteBase
388        variable secsPerMinute
389
390        set minute [expr {([clock seconds] - $minuteBase) / $secsPerMinute}]
391        if {$minute > 59} {
392            # this occurs while debugging if the process is
393            # stopped at a breakpoint too long.
394            set minute 59
395        }
396
397        # Initialize the current bucket and
398        # clear any buckets we've skipped since the last sample.
399       
400        if {$minute != $counter(lastMinute)} {
401            set histogram($minute) 0
402            for {set i [expr {$counter(lastMinute)+1}]} \
403                {$i < $minute} \
404                {incr i} {
405            set histogram($i) 0
406            }
407            set counter(lastMinute) $minute
408        }
409        set histogram($minute) [expr {$histogram($minute) + $delta}]
410        }
411        default {#ignore}
412    }
413#   }
414    return
415}
416
417# ::counter::exists --
418#
419#   Return true if the counter exists.
420#
421# Arguments:
422#   tag The counter identifier.
423#
424# Results:
425#   1 if it has been defined.
426#
427# Side Effects:
428#   None.
429
430proc ::counter::exists {tag} {
431    upvar #0 counter::T-$tag counter
432    return [info exists counter]
433}
434
435# ::counter::get --
436#
437#   Return statistics.
438#
439# Arguments:
440#   tag The counter identifier.
441#   option  What statistic to get
442#   args    Needed by some options.
443#
444# Results:
445#   With no args, just the counter value.
446#
447# Side Effects:
448#   None.
449
450proc ::counter::get {tag {option -total} args} {
451    upvar #0 counter::T-$tag counter
452    switch -- $option {
453    -total {
454        return $counter(total)
455    }
456    -totalVar {
457        return ::counter::T-$tag\(total)
458    }
459    -N {
460        return $counter(N)
461    }
462    -avg {
463        if {$counter(N) == 0} {
464        return 0
465        } else {
466        return [expr {$counter(total) / double($counter(N))}]
467        }
468    }
469    -avgn {
470        if {$counter(type) != "-lastn"} {
471        return -code error "The -avgn option is only supported for -lastn counters."
472        }
473        upvar #0 counter::V-$tag vector
474        set sum 0
475        for {set i 0} {($i < $counter(N)) && ($i < $counter(lastn))} {incr i} {
476        set sum [expr {$sum + $vector($i)}]
477        }
478        if {$i == 0} {
479        return 0
480        } else {
481        return [expr {$sum / double($i)}]
482        }
483    }
484    -hist {
485        upvar #0 counter::H-$tag histogram
486        if {[llength $args]} {
487        # Return particular bucket
488        set bucket [lindex $args 0]
489        if {[info exists histogram($bucket)]} {
490            return $histogram($bucket)
491        } else {
492            return 0
493        }
494        } else {
495        # Dump the whole histogram
496
497        set result {}
498        if {$counter(type) == "-group"} {
499            set sort -dictionary
500        } else {
501            set sort -integer
502        }
503        foreach x [lsort $sort [array names histogram]] {
504            lappend result $x $histogram($x)
505        }
506        return $result
507        }
508    }
509    -histVar {
510        return ::counter::H-$tag
511    }
512    -histHour {
513        upvar #0 counter::Hour-$tag histogram
514        set result {}
515        foreach x [lsort -integer [array names histogram]] {
516        lappend result $x $histogram($x)
517        }
518        return $result
519    }
520    -histHourVar {
521        return ::counter::Hour-$tag
522    }
523    -histDay {
524        upvar #0 counter::Day-$tag histogram
525        set result {}
526        foreach x [lsort -integer [array names histogram]] {
527        lappend result $x $histogram($x)
528        }
529        return $result
530    }
531    -histDayVar {
532        return ::counter::Day-$tag
533    }
534    -maxPerMinute {
535        return $counter(maxPerMinute)
536    }
537    -maxPerHour {
538        return $counter(maxPerHour)
539    }
540    -maxPerDay {
541        return $counter(maxPerDay)
542    }
543    -resetDate {
544        if {[info exists counter(resetDate)]} {
545        return $counter(resetDate)
546        } else {
547        return ""
548        }
549    }
550    -all {
551        return [array get counter]
552    }
553    default {
554        return -code error "Invalid option $option.\
555        Should be -all, -total, -N, -avg, -avgn, -hist, -histHour,\
556        -histDay, -totalVar, -histVar, -histHourVar, -histDayVar -resetDate."
557    }
558    }
559}
560
561# ::counter::names --
562#
563#   Return the list of defined counters.
564#
565# Arguments:
566#   none
567#
568# Results:
569#   A list of counter tags.
570#
571# Side Effects:
572#   None.
573
574proc ::counter::names {} {
575    set result {}
576    foreach v [info vars ::counter::T-*] {
577    if {[info exists $v]} {
578        # Declared arrays might not exist, yet
579        # strip prefix from name
580        set v [string range $v [string length "::counter::T-"] end]
581        lappend result $v
582    }
583    }
584    return $result
585}
586
587# ::counter::MergeHour --
588#
589#   Sum the per-minute histogram into the next hourly bucket.
590#   On 24-hour boundaries, sum the hourly buckets into the next day bucket.
591#   This operates on all time-based histograms.
592#
593# Arguments:
594#   none
595#
596# Results:
597#   none
598#
599# Side Effects:
600#   See description.
601
602proc ::counter::MergeHour {interval} {
603    variable hourIndex
604    variable minuteBase
605    variable hourBase
606    variable tagsToMerge
607    variable secsPerMinute
608
609    after $interval [list counter::MergeHour $interval]
610    if {![info exists hourBase] || $hourIndex == 0} {
611    set hourBase $minuteBase
612    }
613    set minuteBase [clock seconds]
614
615    foreach tag $tagsToMerge {
616    upvar #0 counter::T-$tag counter
617    upvar #0 counter::H-$tag histogram
618    upvar #0 counter::Hour-$tag hourhist
619
620    # Clear any buckets we've skipped since the last sample.
621
622    for {set i [expr {$counter(lastMinute)+1}]} {$i < 60} {incr i} {
623        set histogram($i) 0
624    }
625    set counter(lastMinute) -1
626
627    # Accumulate into the next hour bucket.
628
629    set hourhist($hourIndex) 0
630    set max 0
631    foreach i [array names histogram] {
632        set hourhist($hourIndex) [expr {$hourhist($hourIndex) + $histogram($i)}]
633        if {$histogram($i) > $max} {
634        set max $histogram($i)
635        }
636    }
637    set perSec [expr {$max / $secsPerMinute}]
638    if {$perSec > $counter(maxPerMinute)} {
639        set counter(maxPerMinute) $perSec
640    }
641    }
642    set hourIndex [expr {($hourIndex + 1) % 24}]
643    if {$hourIndex == 0} {
644    counter::MergeDay
645    }
646
647}
648# ::counter::MergeDay --
649#
650#   Sum the per-minute histogram into the next hourly bucket.
651#   On 24-hour boundaries, sum the hourly buckets into the next day bucket.
652#   This operates on all time-based histograms.
653#
654# Arguments:
655#   none
656#
657# Results:
658#   none
659#
660# Side Effects:
661#   See description.
662
663proc ::counter::MergeDay {} {
664    variable dayIndex
665    variable dayBase
666    variable hourBase
667    variable tagsToMerge
668    variable secsPerMinute
669
670    # Save the hours histogram into a bucket for the last day
671    # counter(day,$day) is the starting time for that day bucket
672
673    if {![info exists dayBase]} {
674    set dayBase $hourBase
675    }
676    foreach tag $tagsToMerge {
677    upvar #0 counter::T-$tag counter
678    upvar #0 counter::Day-$tag dayhist
679    upvar #0 counter::Hour-$tag hourhist
680    set dayhist($dayIndex) 0
681    set max 0
682    for {set i 0} {$i < 24} {incr i} {
683        if {[info exists hourhist($i)]} {
684        set dayhist($dayIndex) [expr {$dayhist($dayIndex) + $hourhist($i)}]
685        if {$hourhist($i) > $max} {
686            set max $hourhist($i)
687        }
688        }
689    }
690    set perSec [expr {double($max) / ($secsPerMinute * 60)}]
691    if {$perSec > $counter(maxPerHour)} {
692        set counter(maxPerHour) $perSec
693    }
694    }
695    set perSec [expr {double($dayhist($dayIndex)) / ($secsPerMinute * 60 * 24)}]
696    if {$perSec > $counter(maxPerDay)} {
697    set counter(maxPerDay) $perSec
698    }
699    incr dayIndex
700}
701
702# ::counter::histHtmlDisplay --
703#
704#   Create an html display of the histogram.
705#
706# Arguments:
707#   tag The counter tag
708#   args    option, value pairs that affect the display:
709#       -title  Label to display above bar chart
710#       -unit   minutes, hours, or days select time-base histograms.
711#           Specify anything else for value-based histograms.
712#       -images URL of /images directory.
713#       -gif    Image for normal histogram bars
714#       -ongif  Image for the active histogram bar
715#       -max    Maximum number of value-based buckets to display
716#       -height Pixel height of the highest bar
717#       -width  Pixel width of each bar
718#       -skip   Buckets to skip when labeling value-based histograms
719#       -format Format used to display labels of buckets.
720#       -text   If 1, a text version of the histogram is dumped,
721#           otherwise a graphical one is generated.
722#
723# Results:
724#   HTML for the display as a complete table.
725#
726# Side Effects:
727#   None.
728
729proc ::counter::histHtmlDisplay {tag args} {
730    append result "<p>\n<table border=0 cellpadding=0 cellspacing=0>\n"
731    append result [eval {counter::histHtmlDisplayRow $tag} $args]
732    append result </table>
733    return $result
734}
735
736# ::counter::histHtmlDisplayRow --
737#
738#   Create an html display of the histogram.
739#
740# Arguments:
741#   See counter::histHtmlDisplay
742#
743# Results:
744#   HTML for the display.  Ths is one row of a 2-column table,
745#   the calling page must define the <table> tag.
746#
747# Side Effects:
748#   None.
749
750proc ::counter::histHtmlDisplayRow {tag args} {
751    upvar #0 counter::T-$tag counter
752    variable secsPerMinute
753    variable minuteBase
754    variable hourBase
755    variable dayBase
756    variable hourIndex
757    variable dayIndex
758
759    array set options [list \
760    -title  $tag \
761    -unit   "" \
762    -images /images \
763    -gif    Blue.gif \
764    -ongif  Red.gif \
765    -max    -1 \
766    -height 100 \
767    -width  4 \
768    -skip   4 \
769    -format %.2f \
770    -text   0
771    ]
772    array set options $args
773
774    # Support for self-posting pages that can clear counters.
775
776    append result "<!-- resetCounter [ncgi::value resetCounter] -->"
777    if {[ncgi::value resetCounter] == $tag} {
778    counter::reset $tag
779    return "<!-- Reset $tag counter -->"
780    }
781
782    switch -glob -- $options(-unit) {
783    min* {
784        upvar #0 counter::H-$tag histogram
785        set histname counter::H-$tag
786        if {![info exists minuteBase]} {
787        return "<!-- No time-based histograms defined -->"
788        }
789        set time $minuteBase
790        set secsForMax $secsPerMinute
791        set periodMax $counter(maxPerMinute)
792        set curIndex [expr {([clock seconds] - $minuteBase) / $secsPerMinute}]
793        set options(-max) 60
794        set options(-min) 0
795    }
796    hour* {
797        upvar #0 counter::Hour-$tag histogram
798        set histname counter::Hour-$tag
799        if {![info exists hourBase]} {
800        return "<!-- Hour merge has not occurred -->"
801        }
802        set time $hourBase
803        set secsForMax [expr {$secsPerMinute * 60}]
804        set periodMax $counter(maxPerHour)
805        set curIndex [expr {$hourIndex - 1}]
806        if {$curIndex < 0} {
807        set curIndex 23
808        }
809        set options(-max) 24
810        set options(-min) 0
811    }
812    day* {
813        upvar #0 counter::Day-$tag histogram
814        set histname counter::Day-$tag
815        if {![info exists dayBase]} {
816        return "<!-- Hour merge has not occurred -->"
817        }
818        set time $dayBase
819        set secsForMax [expr {$secsPerMinute * 60 * 24}]
820        set periodMax $counter(maxPerDay)
821        set curIndex dayIndex
822        set options(-max) $dayIndex
823        set options(-min) 0
824    }
825    default {
826        # Value-based histogram with arbitrary units.
827
828        upvar #0 counter::H-$tag histogram
829        set histname counter::H-$tag
830
831        set unit $options(-unit)
832        set curIndex ""
833        set time ""
834    }
835    }
836    if {! [info exists histogram]} {
837    return "<!-- $histname doesn't exist -->\n"
838    }
839
840    set max 0
841    set maxName 0
842    foreach {name value} [array get histogram] {
843    if {$value > $max} {
844        set max $value
845        set maxName $name
846    }
847    }
848
849    # Start 2-column HTML display.  A summary table at the left, the histogram on the right.
850
851    append result "<tr><td valign=top>\n"
852
853    append result "<table bgcolor=#EEEEEE>\n"
854    append result "<tr><td colspan=2 align=center>[html::font]<b>$options(-title)</b></font></td></tr>\n"
855    append result "<tr><td>[html::font]<b>Total</b></font></td>"
856    append result "<td>[html::font][format $options(-format) $counter(total)]</font></td></tr>\n"
857
858    if {[info exists secsForMax]} {
859
860    # Time-base histogram
861
862    set string {}
863    set t $secsForMax
864    set days [expr {$t / (60 * 60 * 24)}]
865    if {$days == 1} {
866        append string "1 Day "
867    } elseif {$days > 1} {
868        append string "$days Days "
869    }
870    set t [expr {$t - $days * (60 * 60 * 24)}]
871    set hours [expr {$t / (60 * 60)}]
872    if {$hours == 1} {
873        append string "1 Hour "
874    } elseif {$hours > 1} {
875        append string "$hours Hours "
876    }
877    set t [expr {$t - $hours * (60 * 60)}]
878    set mins [expr {$t / 60}]
879    if {$mins == 1} {
880        append string "1 Minute "
881    } elseif {$mins > 1} {
882        append string "$mins Minutes "
883    }
884    set t [expr {$t - $mins * 60}]
885    if {$t == 1} {
886        append string "1 Second "
887    } elseif {$t > 1} {
888        append string "$t Seconds "
889    }
890    append result "<tr><td>[html::font]<b>Bucket Size</b></font></td>"
891    append result "<td>[html::font]$string</font></td></tr>\n"
892
893    append result "<tr><td>[html::font]<b>Max Per Sec</b></font></td>"
894    append result "<td>[html::font][format %.2f [expr {$max/double($secsForMax)}]]</font></td></tr>\n"
895
896    if {$periodMax > 0} {
897        append result "<tr><td>[html::font]<b>Best Per Sec</b></font></td>"
898        append result "<td>[html::font][format %.2f $periodMax]</font></td></tr>\n"
899    }
900    append result "<tr><td>[html::font]<b>Starting Time</b></font></td>"
901    switch -glob -- $options(-unit) {
902        min* {
903        append result "<td>[html::font][clock format $time \
904            -format %k:%M:%S]</font></td></tr>\n"
905        }
906        hour* {
907        append result "<td>[html::font][clock format $time \
908            -format %k:%M:%S]</font></td></tr>\n"
909        }
910        day* {
911        append result "<td>[html::font][clock format $time \
912            -format "%b %d %k:%M"]</font></td></tr>\n"
913        }
914        default {#ignore}
915    }
916
917    } else {
918
919    # Value-base histogram
920
921    set ix [lsort -integer [array names histogram]]
922
923    set mode [expr {$counter(bucketsize) * $maxName}]
924    set first [expr {$counter(bucketsize) * [lindex $ix 0]}]
925    set last [expr {$counter(bucketsize) * [lindex $ix end]}]
926
927    append result "<tr><td>[html::font]<b>Average</b></font></td>"
928    append result "<td>[html::font][format $options(-format) [counter::get $tag -avg]]</font></td></tr>\n"
929
930    append result "<tr><td>[html::font]<b>Mode</b></font></td>"
931    append result "<td>[html::font]$mode</font></td></tr>\n"
932
933    append result "<tr><td>[html::font]<b>Minimum</b></font></td>"
934    append result "<td>[html::font]$first</font></td></tr>\n"
935
936    append result "<tr><td>[html::font]<b>Maximum</b></font></td>"
937    append result "<td>[html::font]$last</font></td></tr>\n"
938
939    append result "<tr><td>[html::font]<b>Unit</b></font></td>"
940    append result "<td>[html::font]$unit</font></td></tr>\n"
941
942    append result "<tr><td colspan=2 align=center>[html::font]<b>"
943    append result "<a href=[ncgi::urlStub]?resetCounter=$tag>Reset</a></td></tr>\n"
944
945    if {$options(-max) < 0} {
946        set options(-max) [lindex $ix end]
947    }
948    if {![info exists options(-min)]} {
949        set options(-min) [lindex $ix 0]
950    }
951    }
952
953    # End table nested inside left-hand column
954
955    append result </table>\n
956    append result </td>\n
957    append result "<td valign=bottom>\n"
958
959
960    # Display the histogram
961
962    if {$options(-text)} {
963    } else {
964    append result [eval \
965        {counter::histHtmlDisplayBarChart $tag histogram $max $curIndex $time} \
966        [array get options]]
967    }
968
969    # Close the right hand column, but leave our caller's table open.
970
971    append result </td></tr>\n
972
973    return $result
974}
975
976# ::counter::histHtmlDisplayBarChart --
977#
978#   Create an html display of the histogram.
979#
980# Arguments:
981#   tag     The counter tag.
982#   histVar     The name of the histogram array
983#   max     The maximum counter value in a histogram bucket.
984#   curIndex    The "current" histogram index, for time-base histograms.
985#   time        The base, or starting time, for the time-based histograms.
986#   args        The array get of the options passed into histHtmlDisplay
987#
988# Results:
989#   HTML for the bar chart.
990#
991# Side Effects:
992#   See description.
993
994proc ::counter::histHtmlDisplayBarChart {tag histVar max curIndex time args} {
995    upvar #0 counter::T-$tag counter
996    upvar 1 $histVar histogram
997    variable secsPerMinute
998    array set options $args
999
1000    append result "<table cellpadding=0 cellspacing=0 bgcolor=#eeeeee><tr>\n"
1001
1002    set ix [lsort -integer [array names histogram]]
1003
1004    for {set t $options(-min)} {$t < $options(-max)} {incr t} {
1005    if {![info exists histogram($t)]} {
1006        set value 0
1007    } else {
1008        set value $histogram($t)
1009    }
1010    if {$max == 0 || $value == 0} {
1011        set height 1
1012    } else {
1013        set percent [expr {round($value * 100.0 / $max)}]
1014        set height [expr {$percent * $options(-height) / 100}]
1015    }
1016    if {$t == $curIndex} {
1017        set img src=$options(-images)/$options(-ongif)
1018    } else {
1019        set img src=$options(-images)/$options(-gif)
1020    }
1021    append result "<td valign=bottom><img $img height=$height\
1022        width=$options(-width) title=$value alt=$value></td>\n"
1023    }
1024    append result "</tr>"
1025
1026    # Count buckets outside the range requested
1027
1028    set overflow 0
1029    set underflow 0
1030    foreach t [lsort -integer [array names histogram]] {
1031    if {($options(-max) > 0) && ($t > $options(-max))} {
1032        incr overflow
1033    }
1034    if {($options(-min) >= 0) && ($t < $options(-min))} {
1035        incr underflow
1036    }
1037    }
1038
1039    # Append a row of labels at the bottom.
1040
1041    set colors {black #CCCCCC}
1042    set bgcolors {#CCCCCC black}
1043    set colori 0
1044    if {$counter(type) != "-timehist"} {
1045
1046    # Label each bucket with its value
1047    # This is probably wrong for hist2x and hist10x
1048
1049    append result "<tr>"
1050    set skip $options(-skip)
1051    if {![info exists counter(mult)]} {
1052        set counter(mult) 1
1053    }
1054
1055    # These are tick marks
1056
1057    set img src=$options(-images)/$options(-gif)
1058    append result "<tr>"
1059    for {set i $options(-min)} {$i < $options(-max)} {incr i} {
1060        if {(($i % $skip) == 0)} {
1061        append result "<td valign=bottom><img $img height=3 \
1062            width=1></td>\n"
1063        } else {
1064        append result "<td valign=bottom></td>"
1065        }
1066    }
1067    append result </tr>
1068
1069    # These are the labels
1070
1071    append result "<tr>"
1072    for {set i $options(-min)} {$i < $options(-max)} {incr i} {
1073        if {$counter(type) == "-histlog"} {
1074        if {[catch {expr {int(log($i) * $counter(bucketsize))}} x]} {
1075            # Out-of-bounds
1076            break
1077        }
1078        } else {
1079        set x [expr {$i * $counter(bucketsize) * $counter(mult)}]
1080        }
1081        set label [format $options(-format) $x]
1082        if {(($i % $skip) == 0)} {
1083        set color [lindex $colors $colori]
1084        set bg [lindex $bgcolors $colori]
1085        set colori [expr {($colori+1) % 2}]
1086        append result "<td colspan=$skip><font size=1 color=$color>$label</font></td>"
1087        }
1088    }
1089    append result </tr>
1090    } else {
1091    switch -glob -- $options(-unit) {
1092        min*    {
1093        if {$secsPerMinute != 60} {
1094            set format %k:%M:%S
1095            set skip 12
1096        } else {
1097            set format %k:%M
1098            set skip 4
1099        }
1100        set deltaT $secsPerMinute
1101        set wrapDeltaT [expr {$secsPerMinute * -59}]
1102        }
1103        hour*   {
1104        if {$secsPerMinute != 60} {
1105            set format %k:%M
1106            set skip 4
1107        } else {
1108            set format %k
1109            set skip 2
1110        }
1111        set deltaT [expr {$secsPerMinute * 60}]
1112        set wrapDeltaT [expr {$secsPerMinute * 60 * -23}]
1113        }
1114        day* {
1115        if {$secsPerMinute != 60} {
1116            set format "%m/%d %k:%M"
1117            set skip 10
1118        } else {
1119            set format %k
1120            set skip $options(-skip)
1121        }
1122        set deltaT [expr {$secsPerMinute * 60 * 24}]
1123        set wrapDeltaT 0
1124        }
1125        default {#ignore}
1126    }
1127    # These are tick marks
1128
1129    set img src=$options(-images)/$options(-gif)
1130    append result "<tr>"
1131    foreach t [lsort -integer [array names histogram]] {
1132        if {(($t % $skip) == 0)} {
1133        append result "<td valign=bottom><img $img height=3 \
1134            width=1></td>\n"
1135        } else {
1136        append result "<td valign=bottom></td>"
1137        }
1138    }
1139    append result </tr>
1140
1141    set lastLabel ""
1142    append result "<tr>"
1143    foreach t [lsort -integer [array names histogram]] {
1144
1145        # Label each bucket with its time
1146
1147        set label [clock format $time -format $format]
1148        if {(($t % $skip) == 0) && ($label != $lastLabel)} {
1149        set color [lindex $colors $colori]
1150        set bg [lindex $bgcolors $colori]
1151        set colori [expr {($colori+1) % 2}]
1152        append result "<td colspan=$skip><font size=1 color=$color>$label</font></td>"
1153        set lastLabel $label
1154        }
1155        if {$t == $curIndex} {
1156        incr time $wrapDeltaT
1157        } else {
1158        incr time $deltaT
1159        }
1160    }
1161    append result </tr>\n
1162    }
1163    append result "</table>"
1164    if {$underflow > 0} {
1165    append result "<br>Skipped $underflow samples <\
1166        [expr {$options(-min) * $counter(bucketsize)}]\n"
1167    }
1168    if {$overflow > 0} {
1169    append result "<br>Skipped $overflow samples >\
1170        [expr {$options(-max) * $counter(bucketsize)}]\n"
1171    }
1172    return $result
1173}
1174
1175# ::counter::start --
1176#
1177#   Start an interval timer.  This should be pre-declared with
1178#   type either -hist, -hist2x, or -hist20x
1179#
1180# Arguments:
1181#   tag     The counter identifier.
1182#   instance    There may be multiple intervals outstanding
1183#           at any time.  This serves to distinquish them.
1184#
1185# Results:
1186#   None
1187#
1188# Side Effects:
1189#   Records the starting time for the instance of this interval.
1190
1191proc ::counter::start {tag instance} {
1192    upvar #0 counter::Time-$tag time
1193    # clock clicks can return negative values if the sign bit is set
1194    # Here we turn it into a 31-bit counter because we only want
1195    # relative differences
1196    set msec [expr {[clock clicks -milliseconds] & 0x7FFFFFFF}]
1197    set time($instance) [list $msec [clock seconds]]
1198}
1199
1200# ::counter::stop --
1201#
1202#   Record an interval timer.
1203#
1204# Arguments:
1205#   tag     The counter identifier.
1206#   instance    There may be multiple intervals outstanding
1207#           at any time.  This serves to distinquish them.
1208#   func        An optional function used to massage the time
1209#           stamp before putting into the histogram.
1210#
1211# Results:
1212#   None
1213#
1214# Side Effects:
1215#   Computes the current interval and adds it to the histogram.
1216
1217proc ::counter::stop {tag instance {func ::counter::Identity}} {
1218    upvar #0 counter::Time-$tag time
1219
1220    if {![info exists time($instance)]} {
1221        # Extra call. Ignore so we can debug error cases.
1222        return
1223    }
1224    set msec [expr {[clock clicks -milliseconds] & 0x7FFFFFFF}]
1225    set now [list $msec [clock seconds]]
1226    set delMicros [expr {[lindex $now 0] - [lindex $time($instance) 0]}]
1227    if {$delMicros < 0} {
1228      # Microsecond counter wrapped.
1229      set delMicros [expr {0x7FFFFFFF - [lindex $time($instance) 0] +
1230                            [lindex $now 0]}]
1231    }
1232    set delSecond [expr {[lindex $now 1] - [lindex $time($instance) 1]}]
1233    unset time($instance)
1234
1235    # It is quite possible that the millisecond counter is much
1236    # larger than 1000, so we just use it unless our microsecond
1237    # calculation is screwed up.
1238
1239    if {$delMicros >= 0} {
1240      counter::count $tag [$func [expr {$delMicros / 1000.0}]]
1241    } else {
1242      counter::count $tag [$func $delSecond]
1243    }
1244}
1245
1246# ::counter::Identity --
1247#
1248#   Return its argument.  This is used as the default function
1249#   to apply to an interval timer.
1250#
1251# Arguments:
1252#   x       Some value.
1253#
1254# Results:
1255#   $x
1256#
1257# Side Effects:
1258#   None
1259
1260
1261proc ::counter::Identity {x} {
1262    return $x
1263}
1264
1265package provide counter 2.0.4
Note: See TracBrowser for help on using the repository browser.