Here's yet another tcl web-load tester, inspired by the torture script in the tclhttpd distribution. It allows you to send requests to a webserver either at a constant rate or as fast as the server can handle them. Its too slow for benchmarking (I can only get it to send a few hundred requests a second) but somewhat useful for real-world tests where a web app may only be able to handle a few dozen hits a second but that's all that will ever be needed.
That characterization of 'too slow for benchmarking but fine for the real world' seems rather appropriate to tcl. It also goes to show how nice the tcl event loop is; I'd expect threads to be the first resort in many languages but they're not really necessary.
Behavior should be fairly self-explanitory. Enter a url with an optional parameter (indentified with %1) that will be expanded on each request to one of the values from the list. Using different parameters may reduce the effectiveness of caching and simulate a more real-world hit pattern.
Performance isn't as good as I'd like, particularly the constant-load operation where I think it will stop issuing requests against a fast server sooner than it should. Any improvements are welcome.
Possible enhancements are better interfaces to parameters (load from a file?) generate reports, graph response times, or make whatever pretty pictures are needed to impress the suits.
As with any web tester, be careful if you're testing a forking webserver, as its pretty easy to drive the load through the roof. With constant-load operation this is less of a problem.
# Tcl web load tester, with constant-rate and constant-load operation
proc create-buttons {} {
frame .buttons
button .buttons.start -text Start -command start
button .buttons.stop -text Stop -command stop
button .buttons.reset -text Reset -command reset
button .buttons.exit -text Exit -command exit
pack .buttons.start -side left -expand t
pack .buttons.stop -side left -expand t
pack .buttons.reset -side left -expand t
pack .buttons.exit -side left -expand t
pack .buttons -side bottom -fill x
}
proc create-slider {} {
frame .slider
label .slider.display -textvariable ::loadrate -width 4
# the command just sets global load to itself in order to
# trip the vwait in the run-load loop
scale .slider.scale -from 0 -to 500 -orient horizontal -tickinterval 50 -variable ::loadrate -showvalue f -command {set ::load $::load ;#}
pack .slider.display -side left
pack .slider.scale -side left -expand t -fill x
pack .slider -side bottom -fill x
}
proc create-params {} {
frame .params
frame .params.p1
label .params.p1.l -text "Parameter 1"
listbox .params.p1.lb -height 4 -yscrollcommand [list .params.p1.sb set]
bind .params.p1.lb <Enter> {
focus %W
}
bind .params.p1.lb <Delete> {
%W delete active
}
scrollbar .params.p1.sb -orient vertical -command [list .params.p1.lb yview]
entry .params.p1.add
bind .params.p1.add <Return> {
.params.p1.lb insert end [%W get]
%W delete 0 end
}
pack .params.p1.l -side top
pack .params.p1.sb -side left -fill y
pack .params.p1.lb -side left
pack .params.p1.add -side left
pack .params.p1
pack .params -side right
}
proc create-main {} {
frame .main
frame .main.url
label .main.url.l -text URL
entry .main.url.e -textvariable ::url
pack .main.url.l -side left
pack .main.url.e -side left -expand t -fill x
pack .main.url -side top -fill x
label .main.current -textvariable ::current -relief groove
pack .main.current -side bottom
pack .main -side left -expand t -fill x -anchor nw
}
proc create-switch {} {
frame .main.switch
frame .main.switch.load
radiobutton .main.switch.load.b -variable ::method -value load
label .main.switch.load.l -text "load (outstanding requests)"
pack .main.switch.load.b -side left
pack .main.switch.load.l -side left
frame .main.switch.rate
radiobutton .main.switch.rate.b -variable ::method -value rate
label .main.switch.rate.l -text "rate (requests/sec)"
pack .main.switch.rate.b -side left
pack .main.switch.rate.l -side left
pack .main.switch.load -side top -anchor nw
pack .main.switch.rate -side top -anchor nw
pack .main.switch -side left
}
proc create-output {} {
frame .output
text .output.t -width 40 -height 10 -yscrollcommand [list .output.sb set]
scrollbar .output.sb -orient vertical -command [list .output.t yview]
pack .output.sb -side left -fill y
pack .output.t -side right -expand t -fill both
pack .output -side bottom -expand t -fill both
}
proc log {text} {
.output.t insert end "$text\n"
.output.t see end
}
proc setup {} {
create-buttons
create-slider
create-output
create-main
create-params
create-switch
}
# torture code; lifted from torture.tcl from tclhttpd distro
puts "Calibrating clock clicks"
set start [clock clicks]
after 1000
set end [clock clicks]
set rate [expr {($end - $start) / 1.0}]
puts "$rate clicks/second"
proc CopyDone {s null {bytes 0} {error {}}} {
global conns rate load atime rc current start
close $s
close $null
set finish [clock clicks]
incr atime [expr {$finish-$conns($s)}]
log "request took [format "%1.3f" [expr {($finish-$conns($s))/$rate}]] sec ($bytes bytes received)"
unset conns($s)
incr load -1
incr rc
}
# update the "current" label with avg rate info and so forth once a second
proc keep-current {} {
global rate load atime rc current start running
set now [clock clicks]
set current "Avg Rate: [if {$now > $start} {
format %2.2f [expr {$rc/((1+$now-$start)/$::rate)}]
} else {
concat -
}] requests/sec
Avg time: [if {$rc > 0} {
format %1.3f [expr {$atime/$rc/$::rate}]
} else {
concat -
}] sec
Load: $load Requests: $rc"
after 1000 keep-current
}
# expand parameters in url for each new request
proc make-req {req} {
set l [.params.p1.lb get 0 end]
set ll [llength $l]
set i [expr {int(rand()*$ll)}]
set item [lindex $l $i]
regsub -all {%1} $req $item req
return $req
}
# do one http request
# use fcopy to do the request mostly in the background. The only delay
# should be on the initial connect.
proc doRequest {server port req} {
global conns load
set start [clock clicks]
incr load
set s [socket $server $port]
set conns($s) $start
fconfigure $s -block 0
puts $s "GET [make-req $req] HTTP/1.0"
puts $s "User-agent: Tcl-Web-tester"
puts $s "Host: $server"
puts $s "Accept: */*"
puts $s ""
flush $s
set null [open "/dev/null" w]
fcopy $s $null -command [list CopyDone $s $null]
return $s
}
# make requests as often as needed to keep the load on the server constant
# The load is assumed to be the number of outstanding requests. As soon
# as one completes, start up another.
proc run-load {server port req} {
global loadrate load running rc start atime
puts stderr "server=$server port=$port req=$req"
while {$running} {
# start $loadrate requests
while {$load < $loadrate} {
doRequest $server $port $req
}
# load is decremented by CopyDone, which will allow this to proceed
vwait load
}
}
# issue requests at a constant rate of $loadrate per second
proc run-rate {server port req} {
global loadrate load running delay rc start atime
set delay [expr {1000/$loadrate}]
puts stderr "server=$server port=$port req=$req delay=$delay"
while {$running} {
# recalculate the delay on each loop in case the slider moved
# I don't want to do this from the slider's command as that would
# cause the vwait to complete prematurely.
set delay [expr {1000/$loadrate}]
after $delay {set delay $delay}
doRequest $server $port $req
# this vwait is tripped by the above after
vwait delay
}
}
proc start {} {
global running start rc
# rc: requests completed
set rc 0
set start [clock clicks]
set running 1
if {![regexp {^http://([-a-z0-9.]+)(:([0-9]+))?(/.*)} $::url - server - port req]} {
puts stderr "server not found in $::url"
return
}
if {$port == ""} {
set port 80
}
keep-current
run-$::method $server $port $req
}
proc stop {} {
global running
set running 0
}
proc reset {} {
global start rc atime
set start [clock clicks]
set rc 1
set atime 0
.output.t delete 1.0 end
}
set ::loadrate 1
set ::atime 0
set ::method load
set ::load 0
set ::rc 0
set ::current "No process"
setup