Symaptic: os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/tests/http.test@bde4ae8d615e

     1 # 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 # Copyright (c) 1998-2000 by Ajuba Solutions.

    10 #

    11 # See the file "license.terms" for information on usage and redistribution

    12 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.

    13 #

    14 #

    15 # RCS: @(#) $Id: http.test,v 1.33.2.6 2006/10/06 19:00:53 hobbs Exp $

    17 if {[lsearch [namespace children] ::tcltest] == -1} {

    18     package require tcltest 2

    19     namespace import -force ::tcltest::*

    20 }

    22 if {[catch {package require http 2} version]} {

    23     if {[info exists http2]} {

    24 	catch {puts "Cannot load http 2.* package"}

    25 	return

    26     } else {

    27 	catch {puts "Running http 2.* tests in slave interp"}

    28 	set interp [interp create http2]

    29 	$interp eval [list set http2 "running"]

    30 	$interp eval [list set argv $argv]

    31 	$interp eval [list source [info script]]

    32 	interp delete $interp

    33 	return

    34     }

    35 }

    37 proc bgerror {args} {

    38     global errorInfo

    39     puts stderr "http.test bgerror"

    40     puts stderr [join $args]

    41     puts stderr $errorInfo

    42 }

    44 set port 8010

    45 set bindata "This is binary data\x0d\x0amore\x0dmore\x0amore\x00null"

    46 catch {unset data}

    48 # Ensure httpd file exists

    50 set origFile [file join [pwd] [file dirname [info script]] httpd]

    51 set httpdFile [file join [temporaryDirectory] httpd_[pid]]

    52 if {![file exists $httpdFile]} {

    53     makeFile "" $httpdFile

    54     file delete $httpdFile

    55     file copy $origFile $httpdFile

    56     set removeHttpd 1

    57 }

    59 if {[info commands testthread] == "testthread" && [file exists $httpdFile]} {

    60     set httpthread [testthread create "

    61 	source [list $httpdFile]

    62 	testthread wait

    63     "]

    64     testthread send $httpthread [list set port $port]

    65     testthread send $httpthread [list set bindata $bindata]

    66     testthread send $httpthread {httpd_init $port}

    67     puts "Running httpd in thread $httpthread"

    68 } else {

    69     if {![file exists $httpdFile]} {

    70 	puts "Cannot read $httpdFile script, http test skipped"

    71 	unset port

    72 	return

    73     }

    74     source $httpdFile

    75     # Let the OS pick the port; that's much more flexible

    76     if {[catch {httpd_init 0} listen]} {

    77 	puts "Cannot start http server, http test skipped"

    78 	unset port

    79 	return

    80     } else {

    81 	set port [lindex [fconfigure $listen -sockname] 2]

    82     }

    83 }

    85 test http-1.1 {http::config} {

    86     http::config

    87 } [list -accept */* -proxyfilter http::ProxyRequired -proxyhost {} -proxyport {} -urlencoding utf-8 -useragent "Tcl http client package $version"]

    88 test http-1.2 {http::config} {

    89     http::config -proxyfilter

    90 } http::ProxyRequired

    91 test http-1.3 {http::config} {

    92     catch {http::config -junk}

    93 } 1

    94 test http-1.4 {http::config} {

    95     set savedconf [http::config]

    96     http::config -proxyhost nowhere.come -proxyport 8080 \

    97 	-proxyfilter myFilter -useragent "Tcl Test Suite" \

    98 	-urlencoding iso8859-1

    99     set x [http::config]

   100     eval http::config $savedconf

   101     set x

   102 } {-accept */* -proxyfilter myFilter -proxyhost nowhere.come -proxyport 8080 -urlencoding iso8859-1 -useragent {Tcl Test Suite}}

   103 test http-1.5 {http::config} {

   104     list [catch {http::config -proxyhost {} -junk 8080} msg] $msg

   105 } {1 {Unknown option -junk, must be: -accept, -proxyfilter, -proxyhost, -proxyport, -urlencoding, -useragent}}

   106 test http-1.6 {http::config} {

   107     set enc [list [http::config -urlencoding]]

   108     http::config -urlencoding iso8859-1

   109     lappend enc [http::config -urlencoding]

   110     http::config -urlencoding [lindex $enc 0]

   111     set enc

   112 } {utf-8 iso8859-1}

   114 test http-2.1 {http::reset} {

   115     catch {http::reset http#1}

   116 } 0

   118 test http-3.1 {http::geturl} {

   119     list [catch {http::geturl -bogus flag} msg] $msg

   120 } {1 {Unknown option flag, can be: -binary, -blocksize, -channel, -command, -handler, -headers, -progress, -query, -queryblocksize, -querychannel, -queryprogress, -validate, -timeout, -type}}

   121 test http-3.2 {http::geturl} {

   122     catch {http::geturl http:junk} err

   123     set err

   124 } {Unsupported URL: http:junk}

   125 set url //[info hostname]:$port

   126 set badurl //[info hostname]:6666

   127 test http-3.3 {http::geturl} {

   128     set token [http::geturl $url]

   129     http::data $token

   130 } "<html><head><title>HTTP/1.0 TEST</title></head><body>

   131 <h1>Hello, World!</h1>

   132 <h2>GET /</h2>

   133 </body></html>"

   134 set tail /a/b/c

   135 set url //[info hostname]:$port/a/b/c

   136 set fullurl http://user:pass@[info hostname]:$port/a/b/c

   137 set binurl //[info hostname]:$port/binary

   138 set posturl //[info hostname]:$port/post

   139 set badposturl //[info hostname]:$port/droppost

   140 set badcharurl //%user@[info hostname]:$port/a/^b/c

   142 test http-3.4 {http::geturl} {

   143     set token [http::geturl $url]

   144     http::data $token

   145 } "<html><head><title>HTTP/1.0 TEST</title></head><body>

   146 <h1>Hello, World!</h1>

   147 <h2>GET $tail</h2>

   148 </body></html>"

   149 proc selfproxy {host} {

   150     global port

   151     return [list [info hostname] $port]

   152 }

   153 test http-3.5 {http::geturl} {

   154     http::config -proxyfilter selfproxy

   155     set token [http::geturl $url]

   156     http::config -proxyfilter http::ProxyRequired

   157     http::data $token

   158 } "<html><head><title>HTTP/1.0 TEST</title></head><body>

   159 <h1>Hello, World!</h1>

   160 <h2>GET http:$url</h2>

   161 </body></html>"

   162 test http-3.6 {http::geturl} {

   163     http::config -proxyfilter bogus

   164     set token [http::geturl $url]

   165     http::config -proxyfilter http::ProxyRequired

   166     http::data $token

   167 } "<html><head><title>HTTP/1.0 TEST</title></head><body>

   168 <h1>Hello, World!</h1>

   169 <h2>GET $tail</h2>

   170 </body></html>"

   171 test http-3.7 {http::geturl} {

   172     set token [http::geturl $url -headers {Pragma no-cache}]

   173     http::data $token

   174 } "<html><head><title>HTTP/1.0 TEST</title></head><body>

   175 <h1>Hello, World!</h1>

   176 <h2>GET $tail</h2>

   177 </body></html>"

   178 test http-3.8 {http::geturl} {

   179     set token [http::geturl $url -query Name=Value&Foo=Bar -timeout 2000]

   180     http::data $token

   181 } "<html><head><title>HTTP/1.0 TEST</title></head><body>

   182 <h1>Hello, World!</h1>

   183 <h2>POST $tail</h2>

   184 <h2>Query</h2>

   185 <dl>

   186 <dt>Name<dd>Value

   187 <dt>Foo<dd>Bar

   188 </dl>

   189 </body></html>"

   190 test http-3.9 {http::geturl} {

   191     set token [http::geturl $url -validate 1]

   192     http::code $token

   193 } "HTTP/1.0 200 OK"

   194 test http-3.10 {http::geturl queryprogress} {

   195     set query foo=bar

   196     set sep ""

   197     set i 0

   198     # Create about 120K of query data

   199     while {$i < 14} {

   200 	incr i

   201 	append query $sep$query

   202 	set sep &

   203     }

   205     proc postProgress {token x y} {

   206 	global postProgress

   207 	lappend postProgress $y

   208     }

   209     set postProgress {}

   210     set t [http::geturl $posturl -query $query \

   211 	    -queryprogress postProgress -queryblocksize 16384]

   212     http::wait $t

   213     list [http::status $t] [string length $query] $postProgress [http::data $t]

   214 } {ok 122879 {16384 32768 49152 65536 81920 98304 114688 122879} {Got 122879 bytes}}

   215 test http-3.11 {http::geturl querychannel with -command} {

   216     set query foo=bar

   217     set sep ""

   218     set i 0

   219     # Create about 120K of query data

   220     while {$i < 14} {

   221 	incr i

   222 	append query $sep$query

   223 	set sep &

   224     }

   225     set file [makeFile $query outdata]

   226     set fp [open $file]

   228     proc asyncCB {token} {

   229 	global postResult

   230 	lappend postResult [http::data $token]

   231     }

   232     set postResult [list ]

   233     set t [http::geturl $posturl -querychannel $fp]

   234     http::wait $t

   235     set testRes [list [http::status $t] [string length $query] [http::data $t]]

   237     # Now do async

   238     http::cleanup $t

   239     close $fp

   240     set fp [open $file]

   241     set t [http::geturl $posturl -querychannel $fp -command asyncCB]

   242     set postResult [list PostStart]

   243     http::wait $t

   244     close $fp

   246     lappend testRes [http::status $t] $postResult

   247     removeFile outdata

   248     set testRes

   249 } {ok 122879 {Got 122880 bytes} ok {PostStart {Got 122880 bytes}}}

   250 # On Linux platforms when the client and server are on the same host, the

   251 # client is unable to read the server's response one it hits the write error.

   252 # The status is "eof".

   253 # On Windows, the http::wait procedure gets a "connection reset by peer" error

   254 # while reading the reply.

   255 test http-3.12 {http::geturl querychannel with aborted request} {nonPortable} {

   256     set query foo=bar

   257     set sep ""

   258     set i 0

   259     # Create about 120K of query data

   260     while {$i < 14} {

   261 	incr i

   262 	append query $sep$query

   263 	set sep &

   264     }

   265     set file [makeFile $query outdata]

   266     set fp [open $file]

   268     proc asyncCB {token} {

   269 	global postResult

   270 	lappend postResult [http::data $token]

   271     }

   272     proc postProgress {token x y} {

   273 	global postProgress

   274 	lappend postProgress $y

   275     }

   276     set postProgress {}

   277     # Now do async

   278     set postResult [list PostStart]

   279     if {[catch {

   280 	set t [http::geturl $badposturl -querychannel $fp -command asyncCB \

   281 		-queryprogress postProgress]

   282 	http::wait $t

   283 	upvar #0 $t state

   284     } err]} {

   285 	puts $errorInfo

   286 	error $err

   287     }

   289     removeFile outdata

   290     list [http::status $t] [http::code $t]

   291 } {ok {HTTP/1.0 200 Data follows}}

   292 test http-3.13 {http::geturl socket leak test} {

   293     set chanCount [llength [file channels]]

   294     for {set i 0} {$i < 3} {incr i} {

   295 	catch {http::geturl $badurl -timeout 5000}

   296     }

   298     # No extra channels should be taken

   299     expr {[llength [file channels]] == $chanCount}

   300 } 1

   301 test http-3.14 "http::geturl $fullurl" {

   302     set token [http::geturl $fullurl -validate 1]

   303     http::code $token

   304 } "HTTP/1.0 200 OK"

   305 test http-3.15 {http::geturl parse failures} -body {

   306     http::geturl "{invalid}:url"

   307 } -returnCodes error -result {Unsupported URL: {invalid}:url}

   308 test http-3.16 {http::geturl parse failures} -body {

   309     http::geturl http:relative/url

   310 } -returnCodes error -result {Unsupported URL: http:relative/url}

   311 test http-3.17 {http::geturl parse failures} -body {

   312     http::geturl /absolute/url

   313 } -returnCodes error -result {Missing host part: /absolute/url}

   314 test http-3.18 {http::geturl parse failures} -body {

   315     http::geturl http://somewhere:123456789/

   316 } -returnCodes error -result {Invalid port number: 123456789}

   317 test http-3.19 {http::geturl parse failures} -body {

   318     set ::http::strict 1

   319     http::geturl http://{user}@somewhere

   320 } -returnCodes error -result {Illegal characters in URL user}

   321 test http-3.20 {http::geturl parse failures} -body {

   322     set ::http::strict 1

   323     http::geturl http://%user@somewhere

   324 } -returnCodes error -result {Illegal encoding character usage "%us" in URL user}

   325 test http-3.21 {http::geturl parse failures} -body {

   326     set ::http::strict 1

   327     http::geturl http://somewhere/{path}

   328 } -returnCodes error -result {Illegal characters in URL path}

   329 test http-3.22 {http::geturl parse failures} -body {

   330     set ::http::strict 1

   331     http::geturl http://somewhere/%path

   332 } -returnCodes error -result {Illegal encoding character usage "%pa" in URL path}

   333 test http-3.23 {http::geturl parse failures} -body {

   334     set ::http::strict 1

   335     http::geturl http://somewhere/path?{query}

   336 } -returnCodes error -result {Illegal characters in URL path}

   337 test http-3.24 {http::geturl parse failures} -body {

   338     set ::http::strict 1

   339     http::geturl http://somewhere/path?%query

   340 } -returnCodes error -result {Illegal encoding character usage "%qu" in URL path}

   341 test http-3.25 {http::geturl parse failures} -body {

   342     set ::http::strict 0

   343     set token [http::geturl $badcharurl]

   344     http::cleanup $token

   345 } -returnCodes ok -result {}

   347 test http-4.1 {http::Event} {

   348     set token [http::geturl $url]

   349     upvar #0 $token data

   350     array set meta $data(meta)

   351     expr ($data(totalsize) == $meta(Content-Length))

   352 } 1

   353 test http-4.2 {http::Event} {

   354     set token [http::geturl $url]

   355     upvar #0 $token data

   356     array set meta $data(meta)

   357     string compare $data(type) [string trim $meta(Content-Type)]

   358 } 0

   359 test http-4.3 {http::Event} {

   360     set token [http::geturl $url]

   361     http::code $token

   362 } {HTTP/1.0 200 Data follows}

   363 test http-4.4 {http::Event} {

   364     set testfile [makeFile "" testfile]

   365     set out [open $testfile w]

   366     set token [http::geturl $url -channel $out]

   367     close $out

   368     set in [open $testfile]

   369     set x [read $in]

   370     close $in

   371     removeFile $testfile

   372     set x

   373 } "<html><head><title>HTTP/1.0 TEST</title></head><body>

   374 <h1>Hello, World!</h1>

   375 <h2>GET $tail</h2>

   376 </body></html>"

   377 test http-4.5 {http::Event} {

   378     set testfile [makeFile "" testfile]

   379     set out [open $testfile w]

   380     set token [http::geturl $url -channel $out]

   381     close $out

   382     upvar #0 $token data

   383     removeFile $testfile

   384     expr $data(currentsize) == $data(totalsize)

   385 } 1

   386 test http-4.6 {http::Event} {

   387     set testfile [makeFile "" testfile]

   388     set out [open $testfile w]

   389     set token [http::geturl $binurl -channel $out]

   390     close $out

   391     set in [open $testfile]

   392     fconfigure $in -translation binary

   393     set x [read $in]

   394     close $in

   395     removeFile $testfile

   396     set x

   397 } "$bindata[string trimleft $binurl /]"

   398 proc myProgress {token total current} {

   399     global progress httpLog

   400     if {[info exists httpLog] && $httpLog} {

   401 	puts "progress $total $current"

   402     }

   403     set progress [list $total $current]

   404 }

   405 if 0 {

   406     # This test hangs on Windows95 because the client never gets EOF

   407     set httpLog 1

   408     test http-4.6.1 {http::Event} knownBug {

   409 	set token [http::geturl $url -blocksize 50 -progress myProgress]

   410 	set progress

   411     } {111 111}

   412 }

   413 test http-4.7 {http::Event} {

   414     set token [http::geturl $url -progress myProgress]

   415     set progress

   416 } {111 111}

   417 test http-4.8 {http::Event} {

   418     set token [http::geturl $url]

   419     http::status $token

   420 } {ok}

   421 test http-4.9 {http::Event} {

   422     set token [http::geturl $url -progress myProgress]

   423     http::code $token

   424 } {HTTP/1.0 200 Data follows}

   425 test http-4.10 {http::Event} {

   426     set token [http::geturl $url -progress myProgress]

   427     http::size $token

   428 } {111}

   429 # Timeout cases

   430 #	Short timeout to working server (the test server). This lets us try a

   431 #	reset during the connection.

   432 test http-4.11 {http::Event} {

   433     set token [http::geturl $url -timeout 1 -command {#}]

   434     http::reset $token

   435     http::status $token

   436 } {reset}

   437 #	Longer timeout with reset.

   438 test http-4.12 {http::Event} {

   439     set token [http::geturl $url/?timeout=10 -command {#}]

   440     http::reset $token

   441     http::status $token

   442 } {reset}

   443 #	Medium timeout to working server that waits even longer. The timeout

   444 #	hits while waiting for a reply.

   445 test http-4.13 {http::Event} {

   446     set token [http::geturl $url?timeout=30 -timeout 10 -command {#}]

   447     http::wait $token

   448     http::status $token

   449 } {timeout}

   450 #	Longer timeout to good host, bad port, gets an error after the

   451 #	connection "completes" but the socket is bad.

   452 test http-4.14 {http::Event} {

   453     set code [catch {

   454 	set token [http::geturl $badurl/?timeout=10 -timeout 10000 -command {#}]

   455 	if {[string length $token] == 0} {

   456 	    error "bogus return from http::geturl"

   457 	}

   458 	http::wait $token

   459 	http::status $token

   460     } err]

   461     # error code varies among platforms.

   462     list $code [regexp {(connect failed|couldn't open socket)} $err]

   463 } {1 1}

   464 # Bogus host

   465 test http-4.15 {http::Event} {

   466     # This test may fail if you use a proxy server.  That is to be

   467     # expected and is not a problem with Tcl.

   468     set code [catch {

   469 	set token [http::geturl //not_a_host.tcl.tk -timeout 1000 -command {#}]

   470 	http::wait $token

   471 	http::status $token

   472     } err]

   473     # error code varies among platforms.

   474     list $code [string match "couldn't open socket*" $err]

   475 } {1 1}

   477 test http-5.1 {http::formatQuery} {

   478     http::formatQuery name1 value1 name2 "value two"

   479 } {name1=value1&name2=value%20two}

   480 # test http-5.2 obsoleted by 5.4 and 5.5 with http 2.5

   481 test http-5.3 {http::formatQuery} {

   482     http::formatQuery lines "line1\nline2\nline3"

   483 } {lines=line1%0d%0aline2%0d%0aline3}

   484 test http-5.4 {http::formatQuery} {

   485     http::formatQuery name1 ~bwelch name2 \xa1\xa2\xa2

   486 } {name1=~bwelch&name2=%c2%a1%c2%a2%c2%a2}

   487 test http-5.5 {http::formatQuery} {

   488     set enc [http::config -urlencoding]

   489     http::config -urlencoding iso8859-1

   490     set res [http::formatQuery name1 ~bwelch name2 \xa1\xa2\xa2]

   491     http::config -urlencoding $enc

   492     set res

   493 } {name1=~bwelch&name2=%a1%a2%a2}

   495 test http-6.1 {http::ProxyRequired} {

   496     http::config -proxyhost [info hostname] -proxyport $port

   497     set token [http::geturl $url]

   498     http::wait $token

   499     http::config -proxyhost {} -proxyport {}

   500     upvar #0 $token data

   501     set data(body)

   502 } "<html><head><title>HTTP/1.0 TEST</title></head><body>

   503 <h1>Hello, World!</h1>

   504 <h2>GET http:$url</h2>

   505 </body></html>"

   507 test http-7.1 {http::mapReply} {

   508     http::mapReply "abc\$\[\]\"\\()\}\{"

   509 } {abc%24%5b%5d%22%5c%28%29%7d%7b}

   510 test http-7.2 {http::mapReply} {

   511     # RFC 2718 specifies that we pass urlencoding on utf-8 chars by default,

   512     # so make sure this gets converted to utf-8 then urlencoded.

   513     http::mapReply "\u2208"

   514 } {%e2%88%88}

   515 test http-7.3 {http::formatQuery} {

   516     set enc [http::config -urlencoding]

   517     # this would be reverting to http <=2.4 behavior

   518     http::config -urlencoding ""

   519     set res [list [catch {http::mapReply "\u2208"} msg] $msg]

   520     http::config -urlencoding $enc

   521     set res

   522 } [list 1 "can't read \"formMap(\u2208)\": no such element in array"]

   523 test http-7.4 {http::formatQuery} {

   524     set enc [http::config -urlencoding]

   525     # this would be reverting to http <=2.4 behavior w/o errors

   526     # (unknown chars become '?')

   527     http::config -urlencoding "iso8859-1"

   528     set res [http::mapReply "\u2208"]

   529     http::config -urlencoding $enc

   530     set res

   531 } {%3f}

   533 # cleanup

   534 catch {unset url}

   535 catch {unset badurl}

   536 catch {unset port}

   537 catch {unset data}

   538 if {[info exists httpthread]} {

   539     testthread send -async $httpthread {

   540 	testthread exit

   541     }

   542 } else {

   543     close $listen

   544 }

   546 if {[info exists removeHttpd]} {

   547     removeFile $httpdFile

   548 }

   550 rename bgerror {}

   551 ::tcltest::cleanupTests

author	sl@SLION-WIN7.fritz.box
	Fri, 15 Jun 2012 03:10:57 +0200
changeset 0	bde4ae8d615e
permissions	-rw-r--r--