Index: library/http/http.tcl
===================================================================
RCS file: /cvsroot/tcl/tcl/library/http/http.tcl,v
retrieving revision 1.39
diff -u -r1.39 http.tcl
--- library/http/http.tcl	2001/09/07 02:43:12	1.39
+++ library/http/http.tcl	2001/11/07 19:27:26
@@ -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.39 2001/09/07 02:43:12 dgp Exp $
+# RCS: @(#) $Id: http.tcl,v 1.32.2.5 2001/09/07 02:43:39 dgp Exp $
 
 # Rough version history:
 # 1.0	Old http_get interface
@@ -21,10 +21,11 @@
 #	"ioerror" status in favor of raising an error
 # 2.4	Added -binary option to http::geturl and charset element
 #	to the state array.
+# 2.5   Added 'gethdr' method, a stripped down 'geturl'.
 
 package require Tcl 8.2
 # keep this in sync with pkgIndex.tcl
-package provide http 2.4
+package provide http 2.5
 
 namespace eval http {
     variable http
@@ -59,7 +60,7 @@
     # This can be changed, but iso8859-1 is the RFC standard.
     variable defaultCharset "iso8859-1"
 
-    namespace export geturl config reset wait formatQuery register unregister
+    namespace export geturl gethdr config reset wait formatQuery register unregister
     # Useful, but not exported: data size status code
 }
 
@@ -253,6 +254,7 @@
         body            {}
 	status		""
 	http            ""
+	mode            url
     }
     set state(charset)	$defaultCharset
     set options {-binary -blocksize -channel -command -handler -headers \
@@ -491,6 +493,248 @@
     return $token
 }
 
+# http::gethdr --
+#
+#	Establishes a connection to a remote url via http.
+#       Retrieves only the header information, no contents.
+#
+# Arguments:
+#       url		The http URL to get.
+#       args		Option value pairs. Valid options include:
+#				-blocksize, -validate, -headers, -timeout
+# Results:
+#	Returns a token for this connection.
+#	This token is the name of an array that the caller should
+#	unset to garbage collect the state.
+
+proc http::gethdr { url args } {
+    variable http
+    variable urlTypes
+    variable defaultCharset
+
+    # Initialize the state variable, an array.  We'll return the
+    # name of this array as the token for the transaction.
+
+    if {![info exists http(uid)]} {
+	set http(uid) 0
+    }
+    set token [namespace current]::[incr http(uid)]
+    variable $token
+    upvar 0 $token state
+    reset $token
+
+    # Process command options.
+
+    array set state {
+	-binary		false
+	-blocksize 	8192
+	-queryblocksize 8192
+	-validate 	0
+	-headers 	{}
+	-timeout 	0
+	-type           application/x-www-form-urlencoded
+	-queryprogress	{}
+	state		header
+	meta		{}
+	coding		{}
+	currentsize	0
+	totalsize	0
+	querylength	0
+	queryoffset	0
+        type            text/html
+        body            {}
+	status		""
+	http            ""
+	mode            hdr
+    }
+    set state(charset)	$defaultCharset
+    set options {-binary -blocksize -channel -command -handler -headers \
+	    -progress -queryblocksize -queryprogress\
+	    -timeout -type}
+    set usage [join $options ", "]
+    regsub -all -- - $options {} options
+    set pat ^-([join $options |])$
+    foreach {flag value} $args {
+	if {[regexp $pat $flag]} {
+	    # Validate numbers
+	    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 integer"
+	    }
+	    set state($flag) $value
+	} else {
+	    unset $token
+	    return -code error "Unknown option $flag, can be: $usage"
+	}
+    }
+
+    # Validate URL, determine the server host and port, and check proxy case
+
+    if {![regexp -nocase {^(([^:]*)://)?([^/:]+)(:([0-9]+))?(/.*)?$} $url \
+	    x prefix proto host y port srvurl]} {
+	unset $token
+	return -code error "Unsupported URL: $url"
+    }
+    if {[string length $proto] == 0} {
+	set proto http
+	set url ${proto}://$url
+    }
+    if {![info exists urlTypes($proto)]} {
+	unset $token
+	return -code error "Unsupported URL type \"$proto\""
+    }
+    set defport [lindex $urlTypes($proto) 0]
+    set defcmd [lindex $urlTypes($proto) 1]
+
+    if {[string length $port] == 0} {
+	set port $defport
+    }
+    if {[string length $srvurl] == 0} {
+	set srvurl /
+    }
+    if {[string length $proto] == 0} {
+	set url http://$url
+    }
+    set state(url) $url
+    if {![catch {$http(-proxyfilter) $host} proxy]} {
+	set phost [lindex $proxy 0]
+	set pport [lindex $proxy 1]
+    }
+
+    # If a timeout is specified we set up the after event
+    # and arrange for an asynchronous socket connection.
+
+    if {$state(-timeout) > 0} {
+	set state(after) [after $state(-timeout) \
+		[list http::reset $token timeout]]
+	set async -async
+    } else {
+	set async ""
+    }
+
+    # If we are using the proxy, we must pass in the full URL that
+    # includes the server name.
+
+    if {[info exists phost] && [string length $phost]} {
+	set srvurl $url
+	set conStat [catch {eval $defcmd $async {$phost $pport}} s]
+    } else {
+	set conStat [catch {eval $defcmd $async {$host $port}} s]
+    }
+    if {$conStat} {
+
+	# something went wrong while trying to establish the connection
+	# Clean up after events and such, but DON'T call the command callback
+	# (if available) because we're going to throw an exception from here
+	# instead.
+	Finish $token "" 1
+	cleanup $token
+	return -code error $s
+    }
+    set state(sock) $s
+
+    # Wait for the connection to complete
+
+    if {$state(-timeout) > 0} {
+	fileevent $s writable [list http::Connect $token]
+	http::wait $token
+
+	if {[string equal $state(status) "error"]} {
+	    # something went wrong while trying to establish the connection
+	    # Clean up after events and such, but DON'T call the command
+	    # callback (if available) because we're going to throw an 
+	    # exception from here instead.
+	    set err [lindex $state(error) 0]
+	    cleanup $token
+	    return -code error $err
+	} elseif {![string equal $state(status) "connect"]} {
+	    # Likely to be connection timeout
+	    return $token
+	}
+	set state(status) ""
+    }
+
+    # Send data in cr-lf format, but accept any line terminators
+
+    fconfigure $s -translation {auto crlf} -buffersize $state(-blocksize)
+
+    # The following is disallowed in safe interpreters, but the socket
+    # is already in non-blocking mode in that case.
+
+    catch {fconfigure $s -blocking off}
+    set how GET
+
+    if {[catch {
+	puts $s "$how $srvurl HTTP/1.0"
+	puts $s "Accept: $http(-accept)"
+	puts $s "Host: $host:$port"
+	puts $s "User-Agent: $http(-useragent)"
+	foreach {key value} $state(-headers) {
+	    regsub -all \[\n\r\]  $value {} value
+	    set key [string trim $key]
+	    if {[string equal $key "Content-Length"]} {
+		set contDone 1
+		set state(querylength) $value
+	    }
+	    if {[string length $key]} {
+		puts $s "$key: $value"
+	    }
+	}
+
+	# Flush the request header and set up the fileevent that will
+	# either push the POST data or read the response.
+	#
+	# fileevent note:
+	#
+	# It is possible to have both the read and write fileevents active
+	# at this point.  The only scenario it seems to affect is a server
+	# that closes the connection without reading the POST data.
+	# (e.g., early versions TclHttpd in various error cases).
+	# Depending on the platform, the client may or may not be able to
+	# get the response from the server because of the error it will
+	# get trying to write the post data.  Having both fileevents active
+	# changes the timing and the behavior, but no two platforms
+	# (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.
+		
+	puts $s ""
+	flush $s
+	fileevent $s readable [list http::Event $token]
+
+	if {! [info exists state(-command)]} {
+	    # geturl does EVERYTHING asynchronously, so if the user
+	    # calls it synchronously, we just do a wait here.
+
+	    wait $token
+	    if {[string equal $state(status) "error"]} {
+		# 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.
+
+	# Clean up after events and such, but DON'T call the command callback
+	# (if available) because we're going to throw an exception from here
+	# instead.
+	
+	# if state(status) is error, it means someone's already called Finish
+	# to do the above-described clean up.
+	if {[string equal $state(status) "error"]} {
+	    Finish $token $err 1
+	}
+	cleanup $token
+	return -code error $err
+    }
+
+    return $token
+}
+
 # Data access functions:
 # Data - the URL data
 # Status - the transaction status: ok, reset, eof, timeout
@@ -671,6 +915,14 @@
 	} elseif {$n == 0} {
 	    variable encodings
 	    set state(state) body
+
+	    if {[string equal $state(mode) "hdr"]} {
+		# Only the header information was asked for, so
+		# interrupt the data transfer now.
+		Eof $token
+		return
+	    }
+
 	    if {$state(-binary) || ![regexp -nocase ^text $state(type)] || \
 		    [regexp gzip|compress $state(coding)]} {
 		# Turn off conversions for non-text data
Index: library/http/pkgIndex.tcl
===================================================================
RCS file: /cvsroot/tcl/tcl/library/http/pkgIndex.tcl,v
retrieving revision 1.8
diff -u -r1.8 pkgIndex.tcl
--- library/http/pkgIndex.tcl	2001/09/07 02:43:12	1.8
+++ library/http/pkgIndex.tcl	2001/11/07 19:27:26
@@ -9,4 +9,4 @@
 # full path name of this file's directory.
 
 if {![package vsatisfies [package provide Tcl] 8.2]} {return}
-package ifneeded http 2.4 [list tclPkgSetup $dir http 2.4 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister}}}]
+package ifneeded http 2.5 [list tclPkgSetup $dir http 2.5 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::gethdr ::http::reset ::http::wait ::http::register ::http::unregister}}}]
Index: unix/Makefile.in
===================================================================
RCS file: /cvsroot/tcl/tcl/unix/Makefile.in,v
retrieving revision 1.83
diff -u -r1.83 Makefile.in
--- unix/Makefile.in	2001/09/10 00:33:09	1.83
+++ unix/Makefile.in	2001/11/07 19:27:26
@@ -569,7 +569,7 @@
 		else true; \
 		fi; \
 	    done;
-	@for i in http2.4 http1.0 opt0.4 encoding msgcat1.2 tcltest2.0; \
+	@for i in http2.5 http1.0 opt0.4 encoding msgcat1.2 tcltest2.0; \
 	    do \
 	    if [ ! -d $(SCRIPT_INSTALL_DIR)/$$i ] ; then \
 		echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \
@@ -597,10 +597,10 @@
 	    do \
 	    $(INSTALL_DATA) $$j $(SCRIPT_INSTALL_DIR)/http1.0; \
 	    done;
-	@echo "Installing library http2.4 directory";
+	@echo "Installing library http2.5 directory";
 	@for j in $(TOP_DIR)/library/http/*.tcl ; \
 	    do \
-	    $(INSTALL_DATA) $$j $(SCRIPT_INSTALL_DIR)/http2.4; \
+	    $(INSTALL_DATA) $$j $(SCRIPT_INSTALL_DIR)/http2.5; \
 	    done;
 	@echo "Installing library opt0.4 directory";
 	@for j in $(TOP_DIR)/library/opt/*.tcl ; \
