OpenCores
URL https://opencores.org/ocsvn/or1k/or1k/trunk

Subversion Repositories or1k

[/] [or1k/] [trunk/] [insight/] [tcl/] [tests/] [http.test] - Blame information for rev 1765

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 578 markom
# Commands covered:  http::config, http::geturl, http::wait, http::reset
2
#
3
# This file contains a collection of tests for the http script library.
4
# Sourcing this file into Tcl runs the tests and
5
# generates output for errors.  No output means no errors were found.
6
#
7
# Copyright (c) 1991-1993 The Regents of the University of California.
8
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
9
#
10
# See the file "license.terms" for information on usage and redistribution
11
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
12
#
13
#
14
# RCS: @(#) $Id: http.test,v 1.1.1.1 2002-01-16 10:25:36 markom Exp $
15
 
16
if {[string compare test [info procs test]] == 1} then {source defs}
17
 
18
if {[catch {package require http 2.0}]} {
19
    if {[info exist http2]} {
20
        catch {puts stderr "Cannot load http 2.0 package"}
21
        return
22
    } else {
23
        catch {puts stderr "Running http 2.0 tests in slave interp"}
24
        set interp [interp create http2]
25
        $interp eval [list set http2 "running"]
26
        $interp eval [list source [info script]]
27
        interp delete $interp
28
        return
29
    }
30
}
31
 
32
############### The httpd_ procedures implement a stub http server. ########
33
proc httpd_init {{port 8015}} {
34
    socket -server httpdAccept $port
35
}
36
proc httpd_log {args} {
37
    global httpLog
38
    if {[info exists httpLog] && $httpLog} {
39
        puts stderr "httpd: [join $args { }]"
40
    }
41
}
42
array set httpdErrors {
43
    204 {No Content}
44
    400 {Bad Request}
45
    404 {Not Found}
46
    503 {Service Unavailable}
47
    504 {Service Temporarily Unavailable}
48
    }
49
 
50
proc httpdError {sock code args} {
51
    global httpdErrors
52
    puts $sock "$code $httpdErrors($code)"
53
    httpd_log "error: [join $args { }]"
54
}
55
proc httpdAccept {newsock ipaddr port} {
56
    global httpd
57
    upvar #0 httpd$newsock data
58
 
59
    fconfigure $newsock -blocking 0 -translation {auto crlf}
60
    httpd_log $newsock Connect $ipaddr $port
61
    set data(ipaddr) $ipaddr
62
    fileevent $newsock readable [list httpdRead $newsock]
63
}
64
 
65
# read data from a client request
66
 
67
proc httpdRead { sock } {
68
    upvar #0 httpd$sock data
69
 
70
    set readCount [gets $sock line]
71
    if {![info exists data(state)]} {
72
        if [regexp {(POST|GET|HEAD) ([^?]+)\??([^ ]*) HTTP/1.0} \
73
                $line x data(proto) data(url) data(query)] {
74
            set data(state) mime
75
            httpd_log $sock Query $line
76
        } else {
77
            httpdError $sock 400
78
            httpd_log $sock Error "bad first line:$line"
79
            httpdSockDone $sock
80
        }
81
        return
82
    }
83
 
84
    # string compare $readCount 0 maps -1 to -1, 0 to 0, and > 0 to 1
85
 
86
    set state [string compare $readCount 0],$data(state),$data(proto)
87
    httpd_log $sock $state
88
    switch -- $state {
89
        -1,mime,HEAD    -
90
        -1,mime,GET     -
91
        -1,mime,POST    {
92
            # gets would block
93
            return
94
        }
95
        0,mime,HEAD     -
96
        0,mime,GET      -
97
        0,query,POST    { httpdRespond $sock }
98
        0,mime,POST     { set data(state) query }
99
        1,mime,HEAD     -
100
        1,mime,POST     -
101
        1,mime,GET      {
102
            if [regexp {([^:]+):[       ]*(.*)}  $line dummy key value] {
103
                set data(mime,[string tolower $key]) $value
104
            }
105
        }
106
        1,query,POST    {
107
            append data(query) $line
108
            httpdRespond $sock
109
        }
110
        default {
111
            if [eof $sock] {
112
                httpd_log $sock Error "unexpected eof on <$data(url)> request"
113
            } else {
114
                httpd_log $sock Error "unhandled state <$state> fetching <$data(url)>"
115
            }
116
            httpdError $sock 404
117
            httpdSockDone $sock
118
        }
119
    }
120
}
121
proc httpdSockDone { sock } {
122
upvar #0 httpd$sock data
123
    unset data
124
    close $sock
125
}
126
 
127
# Respond to the query.
128
 
129
set bindata "This is binary data\x0d\x0amore\x0dmore\x0amore\x00null"
130
proc httpdRespond { sock } {
131
    global httpd bindata port
132
    upvar #0 httpd$sock data
133
 
134
    if {[string match *binary* $data(url)]} {
135
        set html "$bindata[info hostname]:$port$data(url)"
136
        set type application/octet-stream
137
    } else {
138
        set type text/html
139
 
140
        set html "HTTP/1.0 TEST
141

Hello, World!

142

$data(proto) $data(url)

143
"
144
        if {[info exists data(query)] && [string length $data(query)]} {
145
            append html "

Query

\n
\n"
146
            foreach {key value} [split $data(query) &=] {
147
                append html "
$key
$value\n"
148
                if {[string compare $key timeout] == 0} {
149
                    # Simulate a timeout by not responding,
150
                    # but clean up our socket later.
151
 
152
                    after 50 [list httpdSockDone $sock]
153
                    httpd_log $sock Noresponse ""
154
                    return
155
                }
156
            }
157
            append html \n
158
        }
159
        append html 
160
    }
161
 
162
    if {$data(proto) == "HEAD"} {
163
        puts $sock "HTTP/1.0 200 OK"
164
    } else {
165
        puts $sock "HTTP/1.0 200 Data follows"
166
    }
167
    puts $sock "Date: [clock format [clock clicks]]"
168
    puts $sock "Content-Type: $type"
169
    puts $sock "Content-Length: [string length $html]"
170
    puts $sock ""
171
    if {$data(proto) != "HEAD"} {
172
        fconfigure $sock -translation binary
173
        puts -nonewline $sock $html
174
    }
175
    httpd_log $sock Done ""
176
    httpdSockDone $sock
177
}
178
##################### end server ###########################
179
 
180
set port 8010
181
if [catch {httpd_init $port} listen] {
182
    puts stderr "Cannot start http server, http test skipped"
183
    unset port
184
    return
185
}
186
 
187
test http-1.1 {http::config} {
188
    http::config
189
} {-accept */* -proxyfilter http::ProxyRequired -proxyhost {} -proxyport {} -useragent {Tcl http client package 2.0}}
190
 
191
test http-1.2 {http::config} {
192
    http::config -proxyfilter
193
} http::ProxyRequired
194
 
195
test http-1.3 {http::config} {
196
    catch {http::config -junk}
197
} 1
198
 
199
test http-1.4 {http::config} {
200
    set savedconf [http::config]
201
    http::config -proxyhost nowhere.come -proxyport 8080 -proxyfilter myFilter -useragent "Tcl Test Suite"
202
    set x [http::config]
203
    eval http::config $savedconf
204
    set x
205
} {-accept */* -proxyfilter myFilter -proxyhost nowhere.come -proxyport 8080 -useragent {Tcl Test Suite}}
206
 
207
test http-1.5 {http::config} {
208
    catch {http::config -proxyhost {} -junk 8080}
209
} 1
210
 
211
test http-2.1 {http::reset} {
212
    catch {http::reset http#1}
213
} 0
214
 
215
test http-3.1 {http::geturl} {
216
    catch {http::geturl -bogus flag}
217
} 1
218
test http-3.2 {http::geturl} {
219
    catch {http::geturl http:junk} err
220
    set err
221
} {Unsupported URL: http:junk}
222
 
223
set url [info hostname]:$port
224
test http-3.3 {http::geturl} {
225
    set token [http::geturl $url]
226
    http::data $token
227
} "HTTP/1.0 TEST
228

Hello, World!

229

GET /

230
"
231
 
232
set tail /a/b/c
233
set url [info hostname]:$port/a/b/c
234
set binurl [info hostname]:$port/binary
235
 
236
test http-3.4 {http::geturl} {
237
    set token [http::geturl $url]
238
    http::data $token
239
} "HTTP/1.0 TEST
240

Hello, World!

241

GET $tail

242
"
243
 
244
proc selfproxy {host} {
245
    global port
246
    return [list [info hostname] $port]
247
}
248
test http-3.5 {http::geturl} {
249
    http::config -proxyfilter selfproxy
250
    set token [http::geturl $url]
251
    http::config -proxyfilter http::ProxyRequired
252
    http::data $token
253
} "HTTP/1.0 TEST
254

Hello, World!

255

GET http://$url

256
"
257
 
258
test http-3.6 {http::geturl} {
259
    http::config -proxyfilter bogus
260
    set token [http::geturl $url]
261
    http::config -proxyfilter http::ProxyRequired
262
    http::data $token
263
} "HTTP/1.0 TEST
264

Hello, World!

265

GET $tail

266
"
267
 
268
test http-3.7 {http::geturl} {
269
    set token [http::geturl $url -headers {Pragma no-cache}]
270
    http::data $token
271
} "HTTP/1.0 TEST
272

Hello, World!

273

GET $tail

274
"
275
 
276
test http-3.8 {http::geturl} {
277
    set token [http::geturl $url -query Name=Value&Foo=Bar]
278
    http::data $token
279
} "HTTP/1.0 TEST
280

Hello, World!

281

POST $tail

282

Query

283
284
Name
Value
285
Foo
Bar
286
287
"
288
 
289
test http-3.9 {http::geturl} {
290
    set token [http::geturl $url -validate 1]
291
    http::code $token
292
} "HTTP/1.0 200 OK"
293
 
294
 
295
test http-4.1 {http::Event} {
296
    set token [http::geturl $url]
297
    upvar #0 $token data
298
    array set meta $data(meta)
299
    expr ($data(totalsize) == $meta(Content-Length))
300
} 1
301
 
302
test http-4.2 {http::Event} {
303
    set token [http::geturl $url]
304
    upvar #0 $token data
305
    array set meta $data(meta)
306
    string compare $data(type) [string trim $meta(Content-Type)]
307
} 0
308
 
309
test http-4.3 {http::Event} {
310
    set token [http::geturl $url]
311
    http::code $token
312
} {HTTP/1.0 200 Data follows}
313
 
314
test http-4.4 {http::Event} {
315
    set out [open testfile w]
316
    set token [http::geturl $url -channel $out]
317
    close $out
318
    set in [open testfile]
319
    set x [read $in]
320
    close $in
321
    file delete testfile
322
    set x
323
} "HTTP/1.0 TEST
324

Hello, World!

325

GET $tail

326
"
327
 
328
test http-4.5 {http::Event} {
329
    set out [open testfile w]
330
    set token [http::geturl $url -channel $out]
331
    close $out
332
    upvar #0 $token data
333
    file delete testfile
334
    expr $data(currentsize) == $data(totalsize)
335
} 1
336
 
337
test http-4.6 {http::Event} {
338
    set out [open testfile w]
339
    set token [http::geturl $binurl -channel $out]
340
    close $out
341
    set in [open testfile]
342
    fconfigure $in -translation binary
343
    set x [read $in]
344
    close $in
345
    file delete testfile
346
    set x
347
} "$bindata$binurl"
348
 
349
proc myProgress {token total current} {
350
    global progress httpLog
351
    if {[info exists httpLog] && $httpLog} {
352
        puts "progress $total $current"
353
    }
354
    set progress [list $total $current]
355
}
356
if 0 {
357
    # This test hangs on Windows95 because the client never gets EOF
358
    set httpLog 1
359
    test http-4.6 {http::Event} {
360
        set token [http::geturl $url -blocksize 50 -progress myProgress]
361
        set progress
362
    } {111 111}
363
}
364
test http-4.7 {http::Event} {
365
    set token [http::geturl $url -progress myProgress]
366
    set progress
367
} {111 111}
368
test http-4.8 {http::Event} {
369
    set token [http::geturl $url]
370
    http::status $token
371
} {ok}
372
test http-4.9 {http::Event} {
373
    set token [http::geturl $url -progress myProgress]
374
    http::code $token
375
} {HTTP/1.0 200 Data follows}
376
test http-4.10 {http::Event} {
377
    set token [http::geturl $url -progress myProgress]
378
    http::size $token
379
} {111}
380
test http-4.11 {http::Event} {
381
    set token [http::geturl $url -timeout 1 -command {#}]
382
    http::reset $token
383
    http::status $token
384
} {reset}
385
test http-4.12 {http::Event} {
386
    set token [http::geturl $url?timeout=10 -timeout 1 -command {#}]
387
    http::wait $token
388
    http::status $token
389
} {timeout}
390
 
391
test http-5.1 {http::formatQuery} {
392
    http::formatQuery name1 value1 name2 "value two"
393
} {name1=value1&name2=value+two}
394
 
395
test http-5.2 {http::formatQuery} {
396
    http::formatQuery name1 ~bwelch name2 \xa1\xa2\xa2
397
} {name1=%7ebwelch&name2=%a1%a2%a2}
398
 
399
test http-5.3 {http::formatQuery} {
400
    http::formatQuery lines "line1\nline2\nline3"
401
} {lines=line1%0d%0aline2%0d%0aline3}
402
 
403
test http-6.1 {http::ProxyRequired} {
404
    http::config -proxyhost [info hostname] -proxyport $port
405
    set token [http::geturl $url]
406
    http::wait $token
407
    http::config -proxyhost {} -proxyport {}
408
    upvar #0 $token data
409
    set data(body)
410
} "HTTP/1.0 TEST
411

Hello, World!

412

GET http://$url

413
"
414
 
415
unset url
416
unset port
417
close $listen

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.