From e793b4a0eb33a970919689caba4daebebcc6e065 Mon Sep 17 00:00:00 2001
From: welch <welch>
Date: Fri, 17 Mar 2000 02:15:18 +0000
Subject: Added tests for -queryprogress

---
 tests/http.test | 25 +++++++++++++++++++++-
 tests/httpd     | 64 +++++++++++++++++++++++++++++++++++----------------------
 2 files changed, 63 insertions(+), 26 deletions(-)

diff --git a/tests/http.test b/tests/http.test
index 62749be..af231d7 100644
--- a/tests/http.test
+++ b/tests/http.test
@@ -12,7 +12,7 @@
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
 #
-# RCS: @(#) $Id: http.test,v 1.14 1999/11/22 20:15:04 welch Exp $
+# RCS: @(#) $Id: http.test,v 1.15 2000/03/17 02:15:18 welch Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest
@@ -121,6 +121,7 @@ test http-3.3 {http::geturl} {
 set tail /a/b/c
 set url [info hostname]:$port/a/b/c
 set binurl [info hostname]:$port/binary
+set posturl [info hostname]:$port/post
 
 test http-3.4 {http::geturl} {
     set token [http::geturl $url]
@@ -180,6 +181,28 @@ test http-3.9 {http::geturl} {
     http::code $token
 } "HTTP/1.0 200 OK"
 
+test http-3.10 {http::geturl queryprogress} {
+    set query foo=bar
+    set sep ""
+    set i 0
+    # Create about 120K of query data
+    while {$i < 14} {
+	incr i
+	append query $sep$query
+	set sep &
+    }
+
+    proc postProgress {token x y} {
+	global postProgress
+	lappend postProgress $x
+    }
+    set postProgress {}
+    set t [http::geturl $posturl -query $query \
+	    -queryprogress postProgress]
+    http::wait $t
+    list [http::status $t] [string length $query] $postProgress [http::data $t]
+} {ok 122879 {16384 32768 49152 65536 81920 98304 114688 131072} {Got 122879 bytes}}
+
 
 test http-4.1 {http::Event} {
     set token [http::geturl $url]
diff --git a/tests/httpd b/tests/httpd
index ddfa6bf..94cfb43 100644
--- a/tests/httpd
+++ b/tests/httpd
@@ -8,6 +8,8 @@
 #
 # SCCS: @(#) httpd 1.2 98/02/20 14:51:59
 
+#set httpLog 1
+
 proc httpd_init {{port 8015}} {
     socket -server httpdAccept $port
 }
@@ -45,8 +47,8 @@ proc httpdAccept {newsock ipaddr port} {
 proc httpdRead { sock } {
     upvar #0 httpd$sock data
 
-    set readCount [gets $sock line]
     if {![info exists data(state)]} {
+	set readCount [gets $sock line]
 	if [regexp {(POST|GET|HEAD) ([^?]+)\??([^ ]*) HTTP/1.0} \
 		$line x data(proto) data(url) data(query)] {
 	    set data(state) mime
@@ -57,12 +59,18 @@ proc httpdRead { sock } {
 	    httpdSockDone $sock
 	}
 	return
-    }
-    # Extra check to handle -1,query,POST case, where we may see eof,
-    # although the data is there, just without a final newline.  A proper
-    # server would handle this better.
-    if {[regexp {Content-Length: (\d+)} $line match length]} {
-	set data(length) $length
+    } elseif {$data(state) == "mime"} {
+	set readCount [gets $sock line]
+	if {[regexp {Content-Length: (\d+)} $line match length]} {
+	    set data(length) $length
+	}
+    } elseif {$data(state) == "query"} {
+	if {![info exist data(length_orig)]} {
+	    set data(length_orig) $data(length)
+	}
+	set line [read $sock $data(length)]
+	set readCount [string length $line]
+	incr data(length) -$readCount
     }
 
     # string compare $readCount 0 maps -1 to -1, 0 to 0, and > 0 to 1
@@ -88,18 +96,17 @@ proc httpdRead { sock } {
 	    }
 	}
 	-1,query,POST	{
-	    if {[info exists data(length)]} {
-		append data(query) [read $sock $data(length)]
-		httpdRespond $sock
-		return
-	    }
 	    httpd_log $sock Error "unexpected eof on <$data(url)> request"
 	    httpdError $sock 404
 	    httpdSockDone $sock
 	}
 	1,query,POST	{
 	    append data(query) $line
-	    httpdRespond $sock
+	    if {$data(length) <= 0} {
+		set data(length) $data(length_orig)
+		httpdRespond $sock
+	    }
+puts stderr "Post Dispatch"
 	}
 	default {
 	    if [eof $sock] {
@@ -124,24 +131,31 @@ 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
+    switch -glob -- $data(url) {
+	*binary* {
+	    set html "$bindata[info hostname]:$port$data(url)"
+	    set type application/octet-stream
+	}
+	*post* {
+	    set html "Got [string length $data(query)] bytes"
+	    set type text/plain
+	}
+	default {
+	    set type text/html
 
-	set html "<html><head><title>HTTP/1.0 TEST</title></head><body>
+	    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 {[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"
+		}
+		append html </dl>\n
 	    }
-	    append html </dl>\n
+	    append html </body></html>
 	}
-	append html </body></html>
     }
 
     if {$data(proto) == "HEAD"} {
-- 
cgit v0.12