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

----
[Category Debugging] |
[Category Internet]