--- ./http.tcl.disabled	2004-10-02 02:57:49.000000000 +0200
+++ ./http.tcl.new	2004-11-11 09:51:54.017173956 +0100
@@ -9,7 +9,7 @@
 # See the file "license.terms" for information on usage and
 # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: http.tcl,v 1.43.2.4 2004/05/25 22:50:47 hobbs Exp $
+# RCS: @(#) $Id: http.tcl,v 1.43 2002/10/03 13:34:32 dkf Exp $
 
 # Rough version history:
 # 1.0	Old http_get interface
@@ -19,13 +19,14 @@
 # 2.3	Added SSL support, and ability to post from a channel
 #	This version also cleans up error cases and eliminates the
 #	"ioerror" status in favor of raising an error
-# 2.4	Added -binary option to http::geturl and charset element
-#	to the state array.
+# 3.0   Added HTTP/1.1 extensions: HTTP 100 (continue) and Chunked Transfer-Encoding
+# 3.1   Added -binary option to http::geturl and charset element
+#       to the state array.
 
 package require Tcl 8.2
 # keep this in sync with pkgIndex.tcl
 # and with the install directories in Makefiles
-package provide http 2.5.0
+package provide http 3.1
 
 namespace eval http {
     variable http
@@ -56,11 +57,11 @@
     array set urlTypes {
 	http	{80 ::socket}
     }
-
+    
     variable encodings [string tolower [encoding names]]
     # This can be changed, but iso8859-1 is the RFC standard.
     variable defaultCharset "iso8859-1"
-
+    
     namespace export geturl config reset wait formatQuery register unregister
     # Useful, but not exported: data size status code
 }
@@ -120,7 +121,7 @@
 	}
 	return $result
     }
-    set options [string map {- ""} $options]
+    regsub -all -- - $options {} options
     set pat ^-([join $options |])$
     if {[llength $args] == 1} {
 	set flag [lindex $args 0]
@@ -165,6 +166,7 @@
     }
     catch {close $state(sock)}
     catch {after cancel $state(after)}
+
     if {[info exists state(-command)] && !$skipCB} {
 	if {[catch {eval $state(-command) {$token}} err]} {
 	    if {[string length $errormsg] == 0} {
@@ -246,9 +248,9 @@
 	-queryprogress	{}
 	state		header
 	meta		{}
-	coding		{}
 	currentsize	0
 	totalsize	0
+	coding  	{}
 	querylength	0
 	queryoffset	0
         type            text/html
@@ -256,28 +258,21 @@
 	status		""
 	http            ""
     }
-    # These flags have their types verified [Bug 811170]
-    array set type {
-	-binary		boolean
-	-blocksize	integer
-	-queryblocksize integer
-	-validate	boolean
-	-timeout	integer
-    }
     set state(charset)	$defaultCharset
     set options {-binary -blocksize -channel -command -handler -headers \
 	    -progress -query -queryblocksize -querychannel -queryprogress\
 	    -validate -timeout -type}
     set usage [join $options ", "]
-    set options [string map {- ""} $options]
+    regsub -all -- - $options {} options
     set pat ^-([join $options |])$
     foreach {flag value} $args {
 	if {[regexp $pat $flag]} {
 	    # Validate numbers
-	    if {[info exists type($flag)] && \
-		    ![string is $type($flag) -strict $value]} {
+	    if {[info exists state($flag)] && \
+		    [string is integer -strict $state($flag)] && \
+		    ![string is integer -strict $value]} {
 		unset $token
-		return -code error "Bad value for $flag ($value), must be $type($flag)"
+		return -code error "Bad value for $flag ($value), must be integer"
 	    }
 	    set state($flag) $value
 	} else {
@@ -296,11 +291,9 @@
     }
 
     # Validate URL, determine the server host and port, and check proxy case
-    # Recognize user:pass@host URLs also, although we do not do anything
-    # with that info yet.
 
-    set exp {^(([^:]*)://)?([^@]+@)?([^/:]+)(:([0-9]+))?(/.*)?$}
-    if {![regexp -nocase $exp $url x prefix proto user host y port srvurl]} {
+    if {![regexp -nocase {^(([^:]*)://)?([^/:]+)(:([0-9]+))?(/.*)?$} $url \
+	    x prefix proto host y port srvurl]} {
 	unset $token
 	return -code error "Unsupported URL: $url"
     }
@@ -413,7 +406,7 @@
     }
 
     if {[catch {
-	puts $s "$how $srvurl HTTP/1.0"
+	puts $s "$how $srvurl HTTP/1.1"
 	puts $s "Accept: $http(-accept)"
 	if {$port == $defport} {
 	    # Don't add port in this case, to handle broken servers.
@@ -423,15 +416,16 @@
 	    puts $s "Host: $host:$port"
 	}
 	puts $s "User-Agent: $http(-useragent)"
+	puts $s "Connection: close"
 	foreach {key value} $state(-headers) {
-	    set value [string map [list \n "" \r ""] $value]
+	    regsub -all \[\n\r\]  $value {} value
 	    set key [string trim $key]
 	    if {[string equal $key "Content-Length"]} {
-		set contDone 1
-		set state(querylength) $value
+	    set contDone 1
+	    set state(querylength) $value
 	    }
 	    if {[string length $key]} {
-		puts $s "$key: $value"
+	    puts $s "$key: $value"
 	    }
 	}
 	if {$isQueryChannel && $state(querylength) == 0} {
@@ -461,7 +455,7 @@
 	# (among Solaris, Linux, and NT)  behave the same, and none 
 	# behave all that well in any case.  Servers should always read thier
 	# POST data if they expect the client to read their response.
-
+		
 	if {$isQuery || $isQueryChannel} {
 	    puts $s "Content-Type: $state(-type)"
 	    if {!$contDone} {
@@ -486,8 +480,9 @@
 		# Something went wrong, so throw the exception, and the
 		# enclosing catch will do cleanup.
 		return -code error [lindex $state(error) 0]
-	    }
+	    }		
 	}
+	
     } err]} {
 	# The socket probably was never connected,
 	# or the connection dropped later.
@@ -543,6 +538,26 @@
     upvar 0 $token state
     return $state(currentsize)
 }
+proc http::charset {token} {
+    variable $token
+    upvar 0 $token state
+    return $state(charset)
+}
+
+proc http::meta {token} {
+    variable $token
+    upvar #0 $token state
+    set max 0
+    foreach {name value} $state(meta) {
+        if {[string length $name] > $max} {
+            set max [string length $name]
+        }
+    }
+    incr max
+    foreach {name value} $state(meta) {
+        puts [format "%-*s %s" $max $name: $value]
+    }
+}
 
 proc http::error {token} {
     variable $token
@@ -595,7 +610,6 @@
     }
     return
 }
-
 # http::Write
 #
 #	Write POST query data to the socket
@@ -610,13 +624,16 @@
     variable $token
     upvar 0 $token state
     set s $state(sock)
-
+    
     # Output a block.  Tcl will buffer this if the socket blocks
+    
     set done 0
     if {[catch {
+	
 	# Catch I/O errors on dead sockets
 
 	if {[info exists state(-query)]} {
+	    
 	    # Chop up large query strings so queryprogress callback
 	    # can give smooth feedback
 
@@ -629,6 +646,7 @@
 		set done 1
 	    }
 	} else {
+	    
 	    # Copy blocks from the query channel
 
 	    set outStr [read $state(-querychannel) $state(-queryblocksize)]
@@ -674,7 +692,7 @@
     upvar 0 $token state
     set s $state(sock)
 
-     if {[eof $s]} {
+    if {[eof $s]} {
 	Eof $token
 	return
     }
@@ -682,33 +700,33 @@
 	if {[catch {gets $s line} n]} {
 	    Finish $token $n
 	} elseif {$n == 0} {
-	    variable encodings
-	    set state(state) body
-	    if {$state(-binary) || ![string match -nocase text* $state(type)]
-		    || [string match *gzip* $state(coding)]
-		    || [string match *compress* $state(coding)]} {
-		# Turn off conversions for non-text data
-		fconfigure $s -translation binary
-		if {[info exists state(-channel)]} {
-		    fconfigure $state(-channel) -translation binary
+	    # empty line marks end of response headers
+	    # http 1.1 allows status 100 (continue)
+	    if {[ncode $token] != "100"} {
+		variable encodings
+		set state(state) body
+		if {$state(-binary) || ![regexp -nocase ^text $state(type)] || [regexp chunked|gzip|compress $state(coding)]} {
+		    # Turn off conversions for non-text data or chunked transfers
+		    fconfigure $s -translation binary
+		    if {[info exists state(-channel)]} {
+			fconfigure $state(-channel) -translation binary
+		    }
+		} else {
+		    # If we are getting text, set the incoming channel's
+		    # encoding correctly.  iso8859-1 is the RFC default, but
+		    # this could be any IANA charset.  However, we only know
+		    # how to convert what we have encodings for.
+		    set idx [lsearch -exact $encodings [string tolower $state(charset)]]
+		    if {$idx >= 0} {
+			fconfigure $s -encoding [lindex $encodings $idx]
+		    }
 		}
-	    } else {
-		# If we are getting text, set the incoming channel's
-		# encoding correctly.  iso8859-1 is the RFC default, but
-		# this could be any IANA charset.  However, we only know
-		# how to convert what we have encodings for.
-		set idx [lsearch -exact $encodings \
-			[string tolower $state(charset)]]
-		if {$idx >= 0} {
-		    fconfigure $s -encoding [lindex $encodings $idx]
+		if {[info exists state(-channel)] && ![info exists state(-handler)]} {
+		    # Initiate a sequence of background fcopies
+		    fileevent $s readable {}
+		    CopyStart $s $token
 		}
-	    }
-	    if {[info exists state(-channel)] && \
-		    ![info exists state(-handler)]} {
-		# Initiate a sequence of background fcopies
-		fileevent $s readable {}
-		CopyStart $s $token
-	    }
+	    }	    
 	} elseif {$n > 0} {
 	    if {[regexp -nocase {^content-type:(.+)$} $line x type]} {
 		set state(type) [string trim $type]
@@ -718,37 +736,78 @@
 	    if {[regexp -nocase {^content-length:(.+)$} $line x length]} {
 		set state(totalsize) [string trim $length]
 	    }
-	    if {[regexp -nocase {^content-encoding:(.+)$} $line x coding]} {
-		set state(coding) [string trim $coding]
+	    if {[regexp -nocase {^transfer-encoding:(.+)$} $line x coding]} {
+		set state(coding) [string trim [string tolower $coding]]
+		set state(-chunksize) 0
 	    }
 	    if {[regexp -nocase {^([^:]+):(.+)$} $line x key value]} {
 		lappend state(meta) $key [string trim $value]
-	    } elseif {[string match HTTP* $line]} {
+	    } elseif {[regexp ^HTTP $line]} {
 		set state(http) $line
 	    }
 	}
     } else {
-	if {[catch {
-	    if {[info exists state(-handler)]} {
-		set n [eval $state(-handler) {$s $token}]
-	    } else {
-		set block [read $s $state(-blocksize)]
-		set n [string length $block]
-		if {$n >= 0} {
-		    append state(body) $block
-		}
-	    }
-	    if {$n >= 0} {
-		incr state(currentsize) $n
-	    }
-	} err]} {
-	    Finish $token $err
-	} else {
-	    if {[info exists state(-progress)]} {
-		eval $state(-progress) \
-			{$token $state(totalsize) $state(currentsize)}
-	    }
-	}
+	    if {[catch {
+            if {[info exists state(-handler)]} {
+                set n [eval $state(-handler) {$s $token}]
+            } else {
+
+                # Sonderbehandlung von chunked Transfer-Encoding -> chunk data einlesen
+                if {($state(coding) == "chunked") && ($state(-chunksize) > 0)} {
+                    set block [read $s $state(-chunksize)]
+                    set n [string length $block]
+                    if {$n >= 0} {
+                        append state(body) $block
+                        set state(-chunksize) [expr $state(-chunksize) - $n]
+                    }
+                    # Chunk-Ende? -> dann \r\n entfernen
+                    if {$state(-chunksize) == 0} {
+                        gets $s
+                    }
+                # -> chunk size einlesen
+                } elseif {($state(coding) == "chunked") && ($state(-chunksize) == 0)} {
+                    set state(-chunksize) [gets $s]
+                    # keine Ahnung warum sich das einmal nicht ausgegangen ist, wurde um ein zeichnen zu wenig eingelesen...
+                    if {($state(-chunksize) != "") && ([string trim $state(-chunksize)] == "")} {
+                        set state(-chunksize) [gets $s]
+                    }
+                    if {($state(-chunksize) != "") && ($state(-chunksize) != 0)} {
+                        set state(-chunksize) [expr "0x$state(-chunksize)"]
+                        # Rest des Blocks einlesen
+                        set block [read $s $state(-chunksize)]
+                        set n [string length $block]
+                        if {$n >= 0} {
+                            append state(body) $block
+                            set state(-chunksize) [expr $state(-chunksize) - $n]
+                        }
+                        # Chunk-Ende? -> dann \r\n entfernen
+                        if {$state(-chunksize) == 0} {
+                            gets $s
+                        }
+                    # letzter Transfer
+                    } else {
+                        gets $s
+                        set n 0
+                    }
+                # kein chunk
+                } else {
+                    set block [read $s $state(-blocksize)]
+                    set n [string length $block]
+                    if {$n >= 0} {
+                        append state(body) $block
+                    }
+                }
+            }
+            if {$n >= 0} {
+                incr state(currentsize) $n
+            }
+        } err]} {
+	        Finish $token $err
+        } else {
+	        if {[info exists state(-progress)]} {
+	            eval $state(-progress) {$token $state(totalsize) $state(currentsize)}
+	        }
+        }
     }
 }
 
@@ -767,10 +826,27 @@
     variable $token
     upvar 0 $token state
     if {[catch {
-	fcopy $s $state(-channel) -size $state(-blocksize) -command \
-	    [list http::CopyDone $token]
+         # Sonderbehandlung von chunked Transfer-Encoding -> chunk data einlesen
+        if {($state(coding) == "chunked") && ($state(-chunksize) > 0)} {
+            fcopy $s $state(-channel) -size $state(-chunksize) -command [list http::CopyDone $token]
+        # -> chunk size einlesen
+        } elseif {($state(coding) == "chunked") && ($state(-chunksize) == 0)} {
+            set state(-chunksize) [gets $s]
+            if {($state(-chunksize) != "") && ($state(-chunksize) != 0)} {
+                set state(-chunksize) [expr "0x$state(-chunksize)"]
+                # Rest des Blocks einlesen
+                fcopy $s $state(-channel) -size $state(-chunksize) -command [list http::CopyDone $token]
+            # letzter Transfer
+            } else {
+                gets $s
+                CopyDone $token 0
+            }
+        # kein chunk
+        } else {
+            fcopy $s $state(-channel) -size $state(-blocksize) -command [list http::CopyDone $token]
+        }
     } err]} {
-	Finish $token $err
+	    Finish $token $err
     }
 }
 
@@ -790,16 +866,26 @@
     upvar 0 $token state
     set s $state(sock)
     incr state(currentsize) $count
+    if {$state(coding) == "chunked"} {
+        if {$count >= 0} {
+            set state(-chunksize) [expr $state(-chunksize) - $count]
+        }
+        # Chunk-Ende? -> dann \r\n entfernen
+        if {$state(-chunksize) == 0} {
+            gets $s
+        }
+    }
+		
     if {[info exists state(-progress)]} {
-	eval $state(-progress) {$token $state(totalsize) $state(currentsize)}
+        eval $state(-progress) {$token $state(totalsize) $state(currentsize)}
     }
     # At this point the token may have been reset
     if {[string length $error]} {
-	Finish $token $error
+        Finish $token $error
     } elseif {[catch {eof $s} iseof] || $iseof} {
-	Eof $token
+        Eof $token
     } else {
-	CopyStart $s $token
+        CopyStart $s $token
     }
 }
 
@@ -866,10 +952,10 @@
     set sep ""
     foreach i $args {
 	append result $sep [mapReply $i]
-	if {[string equal $sep "="]} {
-	    set sep &
-	} else {
+	if {[string compare $sep "="]} {
 	    set sep =
+	} else {
+	    set sep &
 	}
     }
     return $result
@@ -886,19 +972,15 @@
 #       The encoded string
 
 proc http::mapReply {string} {
-    variable http
     variable formMap
     variable alphanumeric
-
+    
     # The spec says: "non-alphanumeric characters are replaced by '%HH'"
     # 1 leave alphanumerics characters alone
     # 2 Convert every other character to an array lookup
     # 3 Escape constructs that are "special" to the tcl parser
     # 4 "subst" the result, doing all the array substitutions
 
-    if {$http(-urlencoding) ne ""} {
-	set string [encoding convertto $http(-urlencoding) $string]
-    }
     regsub -all \[^$alphanumeric\] $string {$formMap(&)} string
     regsub -all {[][{})\\]\)} $string {\\&} string
     return [subst -nocommand $string]
@@ -916,10 +998,11 @@
 proc http::ProxyRequired {host} {
     variable http
     if {[info exists http(-proxyhost)] && [string length $http(-proxyhost)]} {
-	if {![info exists http(-proxyport)] || \
-		![string length $http(-proxyport)]} {
+	if {![info exists http(-proxyport)] || ![string length $http(-proxyport)]} {
 	    set http(-proxyport) 8080
 	}
 	return [list $http(-proxyhost) $http(-proxyport)]
+    } else {
+	return {}
     }
 }
