1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
|
# copyright (C) 1997-2005 Jean-Luc Fontaine (mailto:jfontain@free.fr)
# this program is free software: please read the COPYRIGHT file enclosed in this package or use the Help Copyright menu
# $Id: apachex.tcl,v 2.19 2005/01/02 00:45:07 jfontain Exp $
package provide apachex [lindex {$Revision: 2.19 $} 1]
package require miscellaneous 1
package require apacheutilities 1
namespace eval apachex {
array set data {
updates 0
0,label server 0,type integer 0,message {server number}
1,label generation 1,type integer 1,message {generation (available after version 1.3.6)}
2,label process 2,type dictionary 2,message {operating system process identifier}
3,label accesses 3,type integer 3,message {number of accesses for this connection / this child / this slot}
4,label mode 4,type ascii 4,message\
"_(waiting), Starting, Reading, W(sending), Keepalive,\nD(DNS lookup), Logging, G(finishing), .(no process)"
5,label {CPU usage} 5,type real 5,message {CPU usage in seconds}
6,label {request age} 6,type dictionary\
6,message {time since beginning of most recent request, in d(ays), h(ours), m(inutes) and s(econds)}
7,label {request time} 7,type integer 7,message {milliseconds required to process most recent request}
8,label {connection traffic} 8,type real 8,message {kilobytes transferred for this connection}
9,label {child traffic} 9,type real 9,message {megabytes transferred for this child}
10,label {slot traffic} 10,type real 10,message {total megabytes transferred for this slot}
11,label client 11,type integer 11,message {client network address} 11,anchor left
12,label {virtual host} 12,type integer 12,message {server virtual host} 12,anchor left
13,label request 13,type integer 13,message {HTTP request} 13,anchor left
14,label traffic 14,type real 14,message {kilobytes per second being transferred for this slot}
pollTimes {10 5 20 30 60 120 300}
views {
{visibleColumns {0 1 2 3 4 5} sort {0 increasing}}
{visibleColumns {0 6 7 8 9 10 14} sort {0 increasing}}
{visibleColumns {0 11 12 13} sort {0 increasing}}
}
persistent 1
switches {-r 1 --remote 1 --proxyhost 1 --proxyport 1}
}
set file [open apachex.htm]
set data(helpText) [read $file] ;# initialize HTML help data from file
close $file
unset file
proc initialize {optionsName} {
upvar 1 $optionsName options
variable url
variable data
variable host
set url [::apache::url options host apachex]
set data(identifier) apachex($host)
::apache::configure options
::http::geturl $url -validate 1 ;# test server so an error is generated if not responding
}
proc update {} {
variable url
variable transaction
variable data
if {[info exists transaction]} return ;# busy
if {[catch {set transaction [::http::geturl $url -command ::apachex::completed]} message]} {
flashMessage "error: $message"
cleanupRows voidArray
incr data(updates) ;# show void values
}
}
proc completed {token} {
variable data
variable last
variable transaction
variable host
set valid [expr {[::http::ncode $token] == 200}] ;# sole HTTP code for good transaction
if {$valid} {
set body [set ${token}(body)] ;# keep first table rows except the 1st row (column titles)
set lines [string range $body [expr {[string first </tr> $body] + 5}] [expr {[string first </table> $body] - 1}]]
regsub -all \n [string trim $lines] {} lines ;# carriage returns must be ignored
regsub -all \t $lines { } lines ;# replace all tabs by spaces as tabs will be used as separators
regsub {^<tr[^>]*>} $lines {} lines ;# remove extreme table row markers
regsub {</tr>$} $lines {} lines
# table row markers are row separators (use tab character as replacement)
regsub -all {</tr> *<tr[^>]*>} $lines \t lines
set separator {<td[^>]*>} ;# table cell markers are cell separators
foreach line [split $lines \t] {
regsub ^$separator $line {} line ;# remove leftmost cell marker
regsub -all $separator $line \t line ;# use tab character as separator
set column 0
foreach cell [split $line \t] {
regsub -all {<[^>]+>} $cell {} cell ;# remove all remaining (formatting) tags
if {$column == 0} {
set generation ?
scan $cell %u-%u row generation ;# generation is set here in apache version 1.3.6 and above
set current($row) {} ;# keep track of current rows for latter cleanup
set data($row,$column) $row
set data($row,[incr column]) $generation
} else {
set data($row,$column) $cell
}
incr column
}
set data($row,6) [formattedTime $data($row,6)]
if {[info exists last($row,10)]} {
set data($row,14) [expr {($data($row,10) - $last($row,10)) * 1000.0}] ;# dynamic traffic in kilobytes
} else {
set data($row,14) ?
}
set last($row,10) $data($row,10) ;# save megabytes for slot for dynamic traffic calculations
}
} else {
if {[::http::ncode $token] == 404} {
flashMessage "error: no server status on $host"
} else {
flashMessage "error: [::http::code $token]"
}
}
::http::cleanup $token ;# free transaction data
cleanupRows current
unset transaction ;# ready for next transaction
incr data(updates)
}
proc cleanupRows {currentNames} {
upvar 1 $currentNames current
variable data
variable last
foreach {name row} [array get data *,0] { ;# cleanup vanished rows data
if {[info exists current($row)]} continue
for {set column 0} {$column <= 14} {incr column} {
unset data($row,$column)
}
catch {unset last($row,10)} ;# previous poll data may not exist
}
}
}
|
