Attachment "http.diff.3" to
ticket [479246ffff]
added by
andreas_kupries
2001-11-08 02:33:20.
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 ; \
