Subversion Repositories or1k

# Commands covered:  http::config, http::geturl, http::wait, http::reset
#
# This file contains a collection of tests for the http script library.
# Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
#
# RCS: @(#) $Id: http.test,v 1.1.1.1 2002-01-16 10:25:36 markom Exp $

if {[string compare test [info procs test]] == 1} then {source defs}

if {[catch {package require http 2.0}]} {
    if {[info exist http2]} {
        catch {puts stderr "Cannot load http 2.0 package"}
        return
    } else {
        catch {puts stderr "Running http 2.0 tests in slave interp"}
        set interp [interp create http2]
        $interp eval [list set http2 "running"]
        $interp eval [list source [info script]]
        interp delete $interp
        return
    }
}

############### The httpd_ procedures implement a stub http server. ########
proc httpd_init {{port 8015}} {
    socket -server httpdAccept $port
}
proc httpd_log {args} {
    global httpLog
    if {[info exists httpLog] && $httpLog} {
        puts stderr "httpd: [join $args { }]"
    }
}
array set httpdErrors {
    204 {No Content}
    400 {Bad Request}
    404 {Not Found}
    503 {Service Unavailable}
    504 {Service Temporarily Unavailable}
    }

proc httpdError {sock code args} {
    global httpdErrors
    puts $sock "$code $httpdErrors($code)"
    httpd_log "error: [join $args { }]"
}
proc httpdAccept {newsock ipaddr port} {
    global httpd
    upvar #0 httpd$newsock data

    fconfigure $newsock -blocking 0 -translation {auto crlf}
    httpd_log $newsock Connect $ipaddr $port
    set data(ipaddr) $ipaddr
    fileevent $newsock readable [list httpdRead $newsock]
}

# read data from a client request

proc httpdRead { sock } {
    upvar #0 httpd$sock data

    set readCount [gets $sock line]
    if {![info exists data(state)]} {
        if [regexp {(POST|GET|HEAD) ([^?]+)\??([^ ]*) HTTP/1.0} \
                $line x data(proto) data(url) data(query)] {
            set data(state) mime
            httpd_log $sock Query $line
        } else {
            httpdError $sock 400
            httpd_log $sock Error "bad first line:$line"
            httpdSockDone $sock
        }
        return
    }

    # string compare $readCount 0 maps -1 to -1, 0 to 0, and > 0 to 1

    set state [string compare $readCount 0],$data(state),$data(proto)
    httpd_log $sock $state
    switch -- $state {
        -1,mime,HEAD    -
        -1,mime,GET     -
        -1,mime,POST    {
            # gets would block
            return
        }
        0,mime,HEAD     -
        0,mime,GET      -
        0,query,POST    { httpdRespond $sock }
        0,mime,POST     { set data(state) query }
        1,mime,HEAD     -
        1,mime,POST     -
        1,mime,GET      {
            if [regexp {([^:]+):[       ]*(.*)}  $line dummy key value] {
                set data(mime,[string tolower $key]) $value
            }
        }
        1,query,POST    {
            append data(query) $line
            httpdRespond $sock
        }
        default {
            if [eof $sock] {
                httpd_log $sock Error "unexpected eof on <$data(url)> request"
            } else {
                httpd_log $sock Error "unhandled state <$state> fetching <$data(url)>"
            }
            httpdError $sock 404
            httpdSockDone $sock
        }
    }
}
proc httpdSockDone { sock } {
upvar #0 httpd$sock data
    unset data
    close $sock
}

# Respond to the query.

set bindata "This is binary data\x0d\x0amore\x0dmore\x0amore\x00null"
proc httpdRespond { sock } {
    global httpd bindata port
    upvar #0 httpd$sock data

    if {[string match *binary* $data(url)]} {
        set html "$bindata[info hostname]:$port$data(url)"
        set type application/octet-stream
    } else {
        set type text/html

        set html "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
<h2>$data(proto) $data(url)</h2>
"
        if {[info exists data(query)] && [string length $data(query)]} {
            append html "<h2>Query</h2>\n<dl>\n"
            foreach {key value} [split $data(query) &=] {
                append html "<dt>$key<dd>$value\n"
                if {[string compare $key timeout] == 0} {
                    # Simulate a timeout by not responding,
                    # but clean up our socket later.

                    after 50 [list httpdSockDone $sock]
                    httpd_log $sock Noresponse ""
                    return
                }
            }
            append html </dl>\n
        }
        append html </body></html>
    }

    if {$data(proto) == "HEAD"} {
        puts $sock "HTTP/1.0 200 OK"
    } else {
        puts $sock "HTTP/1.0 200 Data follows"
    }
    puts $sock "Date: [clock format [clock clicks]]"
    puts $sock "Content-Type: $type"
    puts $sock "Content-Length: [string length $html]"
    puts $sock ""
    if {$data(proto) != "HEAD"} {
        fconfigure $sock -translation binary
        puts -nonewline $sock $html
    }
    httpd_log $sock Done ""
    httpdSockDone $sock
}
##################### end server ###########################

set port 8010
if [catch {httpd_init $port} listen] {
    puts stderr "Cannot start http server, http test skipped"
    unset port
    return
}

test http-1.1 {http::config} {
    http::config
} {-accept */* -proxyfilter http::ProxyRequired -proxyhost {} -proxyport {} -useragent {Tcl http client package 2.0}}

test http-1.2 {http::config} {
    http::config -proxyfilter
} http::ProxyRequired

test http-1.3 {http::config} {
    catch {http::config -junk}
} 1

test http-1.4 {http::config} {
    set savedconf [http::config]
    http::config -proxyhost nowhere.come -proxyport 8080 -proxyfilter myFilter -useragent "Tcl Test Suite"
    set x [http::config]
    eval http::config $savedconf
    set x
} {-accept */* -proxyfilter myFilter -proxyhost nowhere.come -proxyport 8080 -useragent {Tcl Test Suite}}

test http-1.5 {http::config} {
    catch {http::config -proxyhost {} -junk 8080}
} 1

test http-2.1 {http::reset} {
    catch {http::reset http#1}
} 0

test http-3.1 {http::geturl} {
    catch {http::geturl -bogus flag}
} 1
test http-3.2 {http::geturl} {
    catch {http::geturl http:junk} err
    set err
} {Unsupported URL: http:junk}

set url [info hostname]:$port
test http-3.3 {http::geturl} {
    set token [http::geturl $url]
    http::data $token
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
<h2>GET /</h2>
</body></html>"

set tail /a/b/c
set url [info hostname]:$port/a/b/c
set binurl [info hostname]:$port/binary

test http-3.4 {http::geturl} {
    set token [http::geturl $url]
    http::data $token
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
<h2>GET $tail</h2>
</body></html>"

proc selfproxy {host} {
    global port
    return [list [info hostname] $port]
}
test http-3.5 {http::geturl} {
    http::config -proxyfilter selfproxy
    set token [http::geturl $url]
    http::config -proxyfilter http::ProxyRequired
    http::data $token
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
<h2>GET http://$url</h2>
</body></html>"

test http-3.6 {http::geturl} {
    http::config -proxyfilter bogus
    set token [http::geturl $url]
    http::config -proxyfilter http::ProxyRequired
    http::data $token
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
<h2>GET $tail</h2>
</body></html>"

test http-3.7 {http::geturl} {
    set token [http::geturl $url -headers {Pragma no-cache}]
    http::data $token
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
<h2>GET $tail</h2>
</body></html>"

test http-3.8 {http::geturl} {
    set token [http::geturl $url -query Name=Value&Foo=Bar]
    http::data $token
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
<h2>POST $tail</h2>
<h2>Query</h2>
<dl>
<dt>Name<dd>Value
<dt>Foo<dd>Bar
</dl>
</body></html>"

test http-3.9 {http::geturl} {
    set token [http::geturl $url -validate 1]
    http::code $token
} "HTTP/1.0 200 OK"


test http-4.1 {http::Event} {
    set token [http::geturl $url]
    upvar #0 $token data
    array set meta $data(meta)
    expr ($data(totalsize) == $meta(Content-Length))
} 1

test http-4.2 {http::Event} {
    set token [http::geturl $url]
    upvar #0 $token data
    array set meta $data(meta)
    string compare $data(type) [string trim $meta(Content-Type)]
} 0

test http-4.3 {http::Event} {
    set token [http::geturl $url]
    http::code $token
} {HTTP/1.0 200 Data follows}

test http-4.4 {http::Event} {
    set out [open testfile w]
    set token [http::geturl $url -channel $out]
    close $out
    set in [open testfile]
    set x [read $in]
    close $in
    file delete testfile
    set x
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
<h2>GET $tail</h2>
</body></html>"

test http-4.5 {http::Event} {
    set out [open testfile w]
    set token [http::geturl $url -channel $out]
    close $out
    upvar #0 $token data
    file delete testfile
    expr $data(currentsize) == $data(totalsize)
} 1

test http-4.6 {http::Event} {
    set out [open testfile w]
    set token [http::geturl $binurl -channel $out]
    close $out
    set in [open testfile]
    fconfigure $in -translation binary
    set x [read $in]
    close $in
    file delete testfile
    set x
} "$bindata$binurl"

proc myProgress {token total current} {
    global progress httpLog
    if {[info exists httpLog] && $httpLog} {
        puts "progress $total $current"
    }
    set progress [list $total $current]
}
if 0 {
    # This test hangs on Windows95 because the client never gets EOF
    set httpLog 1
    test http-4.6 {http::Event} {
        set token [http::geturl $url -blocksize 50 -progress myProgress]
        set progress
    } {111 111}
}
test http-4.7 {http::Event} {
    set token [http::geturl $url -progress myProgress]
    set progress
} {111 111}
test http-4.8 {http::Event} {
    set token [http::geturl $url]
    http::status $token
} {ok}
test http-4.9 {http::Event} {
    set token [http::geturl $url -progress myProgress]
    http::code $token
} {HTTP/1.0 200 Data follows}
test http-4.10 {http::Event} {
    set token [http::geturl $url -progress myProgress]
    http::size $token
} {111}
test http-4.11 {http::Event} {
    set token [http::geturl $url -timeout 1 -command {#}]
    http::reset $token
    http::status $token
} {reset}
test http-4.12 {http::Event} {
    set token [http::geturl $url?timeout=10 -timeout 1 -command {#}]
    http::wait $token
    http::status $token
} {timeout}

test http-5.1 {http::formatQuery} {
    http::formatQuery name1 value1 name2 "value two"
} {name1=value1&name2=value+two}

test http-5.2 {http::formatQuery} {
    http::formatQuery name1 ~bwelch name2 \xa1\xa2\xa2
} {name1=%7ebwelch&name2=%a1%a2%a2}

test http-5.3 {http::formatQuery} {
    http::formatQuery lines "line1\nline2\nline3"
} {lines=line1%0d%0aline2%0d%0aline3}

test http-6.1 {http::ProxyRequired} {
    http::config -proxyhost [info hostname] -proxyport $port
    set token [http::geturl $url]
    http::wait $token
    http::config -proxyhost {} -proxyport {}
    upvar #0 $token data
    set data(body)
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
<h2>GET http://$url</h2>
</body></html>"

unset url
unset port
close $listen