~amsn-daily/amsn/amsn-packaging

##+##########################################################################

#

# Parallel Geturl -- package (and demo) that efficiently downloads large

# numbers of web pages while also handling timeout failures. Web requests

# are queued up and a set number are simultaneously fired off. As requests

# complete, new ones of popped off the queue and launched.

# by Keith Vetter, March 5, 2004

package require Tk

package require http

namespace eval PGU {

	if { $initialize_amsn == 1 } {

		variable options                            ;# User tweakable values

		variable queue                              ;# Request queue

		variable qhead 1                            ;# First empty slot

		variable qtail 0                            ;# Last in use slot

		variable stats                              ;# Array of statistics

		variable wait 0                             ;# For vwait

		variable tokens

		variable last_error ""

		array set options {-degree 10 -timeout 120000 -maxRetries 3}

	}

	proc ::PGU::Reset {} {

		variable queue

		variable stats

		variable qhead 1

		variable qtail 0

		variable wait 0

		variable tokens

		catch {unset queue}

		array set queue {}

		array set stats {qlen 0 pending 0 done 0 timeouts 0}

		foreach id [array names tokens] {

			set token [set tokens($id)]

			catch {::http::reset $token}

			catch {::http::cleanup $token}

		}

		array unset tokens

	}

	if { $initialize_amsn == 1 } {

		::PGU::Reset

	}

	#############################################################################

	#

	# ::PGU::Config -- allow user to configure some parameters

	#

	proc ::PGU::Config {args} {

		variable options

		set o [lsort [array names options]]

		if {[llength $args] == 0} {                 ;# Return all results

			set result {}

			foreach name $o {

				lappend result $name $options($name)

			}

			return $result

		}

		foreach {flag value} $args {                ;# Get one or set some

			if {[lsearch $o $flag] == -1} {

				return -code error "Unknown option $flag, must be: [join $o ", "]"

			}

			if {[llength $args] == 1} {             ;# Get one config value

				return $options($flag)

			}

			set options($flag) $value               ;# Set the config value

		}

	}

	##+##########################################################################

	#

	# ::PGU::Add -- adds a url and callback command to are request queue

	#

	proc ::PGU::Add {url cmd query type headers {nolaunch 0}} {

		variable queue

		variable qtail

		variable stats

		set id [incr qtail]

		set queue($id) [list $url $cmd $query $type $headers 0]

		incr stats(qlen)

		status_log "PGU: Queueing $id for $url : [::PGU::Status]"

		if {!$nolaunch} {

			::PGU::Launch

		}

		return $id

	}

	proc ::PGU::GetLastError {id} {

		variable last_error

		return $last_error

	}

	##+##########################################################################

	#

	# ::PGU::Launch -- launches web requests if we have the capacity

	#

	proc ::PGU::Launch {} {

		variable queue

		variable qtail

		variable qhead

		variable options

		variable stats

		variable tokens

		while {1} {

			if {$qtail < $qhead} return             ;# Empty queue

			if {$stats(pending) >= $options(-degree)} return ;# No slots open

			set id $qhead

			incr qhead

			if {![info exists queue($id)] } continue ; # canceled request

			incr stats(pending)

			incr stats(qlen) -1

			foreach {url cmd query type headers cnt} $queue($id) break

			status_log "PGU: Getting URL $id : [::PGU::Status]"

			if {[catch {set tokens($id) [::http::geturl $url -keepalive 0 -timeout $options(-timeout) \

							 -command [list ::PGU::_HTTPCommand $id] \

							 -query $query -type $type -headers $headers]} res]} {

				status_log "Error calling ::http::geturl : $res"

				if {[catch {eval $cmd ""} emsg]} {

					status_log "PGU Callback error : $emsg\n" red

				}

				set last_error res

			}

		}

	}

	##+##########################################################################

	#

	# ::PGU::_HTTPCommand -- our geturl callback command that handles

	# queue maintenance, timeout retries and user callbacks.

	#

	proc ::PGU::_HTTPCommand {id token} {

		variable queue

		variable stats

		variable options

		variable wait

		variable tokens

		foreach {url cmd query type headers cnt} $queue($id) break

		set status [::http::status $token]

		if {$status == "timeout"} {

			incr stats(timeouts)

			incr cnt -1

			if {abs($cnt) < $options(-maxRetries)} {

				::http::cleanup $token

				array unset tokens $id

				status_log "PGU Callback: request $id timed out, retrying \n" red

				lset queue($id) 5 $cnt              ;# Remember retry attempts

				if {![catch {

					set tokens($id) [::http::geturl $url -keepalive 0 \

							     -timeout $options(-timeout) \

							     -command [list ::PGU::_HTTPCommand $id] \

							     -query $query -type $type \

							     -headers $headers]

				}] } {

					return

				}

			}

		}

		if {[catch {eval $cmd $token} emsg]} {

			status_log "PGU Callback error : $emsg\n" red

		}

		incr stats(pending) -1                      ;# One less outstanding request

		incr stats(done)

		status_log "PGU: Request $id done : [::PGU::Status]"

		::PGU::Launch                               ;# Try launching another request

		::http::cleanup $token

		array unset queue $id

		array unset tokens $id

	}

	proc ::PGU::Cancel {id} {

		variable tokens

		variable queue

		if {[info exists tokens($id)] } {

			set token [set tokens($id)]

			catch {::http::reset $token}

			catch {::http::cleanup $token}

			array unset tokens $id

		}

		array unset queue $id

	}

	##+##########################################################################

	#

	# ::PGU::Status -- returns some statistics of the current state

	#

	proc ::PGU::Status {} {

		variable stats

		return [list $stats(qlen) $stats(pending) $stats(done) $stats(timeouts)]

	}

}