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
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
|
##+##########################################################################
#
# 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)]
}
}
|