2002-05-13 Vince Darley <vincentdarley@sourceforge.net>
* library/webdavvfs.tcl: v. early implementation of a webdav
vfs. (Note: this and the 'http' vfs need lots of work --
- please help out!).
+ please help out!). This requires the '2.6' version of the http
+ package which is distributed with tclvfs.
2002-05-13 Vince Darley <vincentdarley@sourceforge.net>
* library/mk4vfs.tcl: newer version from tclkit.
--- /dev/null
+'\"
+'\" Copyright (c) 1995-1997 Sun Microsystems, Inc.
+'\" Copyright (c) 1998-2000 by Ajuba Solutions.
+'\"
+'\" See the file "license.terms" for information on usage and redistribution
+'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+'\"
+'\" RCS: @(#) $Id$
+'\"
+.so man.macros
+.TH "Http" n 8.3 Tcl "Tcl Built-In Commands"
+.BS
+'\" Note: do not modify the .SH NAME line immediately below!
+.SH NAME
+Http \- Client-side implementation of the HTTP/1.0 protocol.
+.SH SYNOPSIS
+\fBpackage require http ?2.4?\fP
+.sp
+\fB::http::config \fI?options?\fR
+.sp
+\fB::http::geturl \fIurl ?options?\fR
+.sp
+\fB::http::formatQuery \fIlist\fR
+.sp
+\fB::http::reset \fItoken\fR
+.sp
+\fB::http::wait \fItoken\fR
+.sp
+\fB::http::status \fItoken\fR
+.sp
+\fB::http::size \fItoken\fR
+.sp
+\fB::http::code \fItoken\fR
+.sp
+\fB::http::ncode \fItoken\fR
+.sp
+\fB::http::data \fItoken\fR
+.sp
+\fB::http::error \fItoken\fR
+.sp
+\fB::http::cleanup \fItoken\fR
+.sp
+\fB::http::register \fIproto port command\fR
+.sp
+\fB::http::unregister \fIproto\fR
+.BE
+
+.SH DESCRIPTION
+.PP
+The \fBhttp\fR package provides the client side of the HTTP/1.1
+protocol. The package implements the GET, POST, and HEAD operations
+of HTTP/1.1. It allows configuration of a proxy host to get through
+firewalls. The package is compatible with the \fBSafesock\fR security
+policy, so it can be used by untrusted applets to do URL fetching from
+a restricted set of hosts. This package can be extened to support
+additional HTTP transport protocols, such as HTTPS, by providing
+a custom \fBsocket\fR command, via \fBhttp::register\fR.
+.PP
+The \fB::http::geturl\fR procedure does a HTTP transaction.
+Its \fIoptions \fR determine whether a GET, POST, or HEAD transaction
+is performed.
+The return value of \fB::http::geturl\fR is a token for the transaction.
+The value is also the name of an array in the ::http namespace
+that contains state information about the transaction. The elements
+of this array are described in the STATE ARRAY section.
+.PP
+If the \fB-command\fP option is specified, then
+the HTTP operation is done in the background.
+\fB::http::geturl\fR returns immediately after generating the
+HTTP request and the callback is invoked
+when the transaction completes. For this to work, the Tcl event loop
+must be active. In Tk applications this is always true. For pure-Tcl
+applications, the caller can use \fB::http::wait\fR after calling
+\fB::http::geturl\fR to start the event loop.
+.SH COMMANDS
+.TP
+\fB::http::config\fP ?\fIoptions\fR?
+The \fB::http::config\fR command is used to set and query the name of the
+proxy server and port, and the User-Agent name used in the HTTP
+requests. If no options are specified, then the current configuration
+is returned. If a single argument is specified, then it should be one
+of the flags described below. In this case the current value of
+that setting is returned. Otherwise, the options should be a set of
+flags and values that define the configuration:
+.RS
+.TP
+\fB\-accept\fP \fImimetypes\fP
+The Accept header of the request. The default is */*, which means that
+all types of documents are accepted. Otherwise you can supply a
+comma separated list of mime type patterns that you are
+willing to receive. For example, "image/gif, image/jpeg, text/*".
+.TP
+\fB\-proxyhost\fP \fIhostname\fP
+The name of the proxy host, if any. If this value is the
+empty string, the URL host is contacted directly.
+.TP
+\fB\-proxyport\fP \fInumber\fP
+The proxy port number.
+.TP
+\fB\-proxyfilter\fP \fIcommand\fP
+The command is a callback that is made during
+\fB::http::geturl\fR
+to determine if a proxy is required for a given host. One argument, a
+host name, is added to \fIcommand\fR when it is invoked. If a proxy
+is required, the callback should return a two element list containing
+the proxy server and proxy port. Otherwise the filter should return
+an empty list. The default filter returns the values of the
+\fB\-proxyhost\fR and \fB\-proxyport\fR settings if they are
+non-empty.
+.TP
+\fB\-useragent\fP \fIstring\fP
+The value of the User-Agent header in the HTTP request. The default
+is \fB"Tcl http client package 2.2."\fR
+.RE
+.TP
+\fB::http::geturl\fP \fIurl\fP ?\fIoptions\fP?
+The \fB::http::geturl\fR command is the main procedure in the package.
+The \fB\-query\fR option causes a POST operation and
+the \fB\-validate\fR option causes a HEAD operation;
+otherwise, a GET operation is performed. The \fB::http::geturl\fR command
+returns a \fItoken\fR value that can be used to get
+information about the transaction. See the STATE ARRAY and ERRORS section for
+details. The \fB::http::geturl\fR command blocks until the operation
+completes, unless the \fB\-command\fR option specifies a callback
+that is invoked when the HTTP transaction completes.
+\fB::http::geturl\fR takes several options:
+.RS
+.TP
+\fB\-binary\fP \fIboolean\fP
+Specifies whether to force interpreting the url data as binary. Normally
+this is auto-detected (anything not beginning with a \fBtext\fR content
+type or whose content encoding is \fBgzip\fR or \fBcompress\fR is
+considered binary data).
+.TP
+\fB\-blocksize\fP \fIsize\fP
+The blocksize used when reading the URL.
+At most \fIsize\fR bytes are read at once. After each block, a call to the
+\fB\-progress\fR callback is made (if that option is specified).
+.TP
+\fB\-channel\fP \fIname\fP
+Copy the URL contents to channel \fIname\fR instead of saving it in
+\fBstate(body)\fR.
+.TP
+\fB\-command\fP \fIcallback\fP
+Invoke \fIcallback\fP after the HTTP transaction completes.
+This option causes \fB::http::geturl\fP to return immediately.
+The \fIcallback\fP gets an additional argument that is the \fItoken\fR returned
+from \fB::http::geturl\fR. This token is the name of an array that is
+described in the STATE ARRAY section. Here is a template for the
+callback:
+.RS
+.CS
+proc httpCallback {token} {
+ upvar #0 $token state
+ # Access state as a Tcl array
+}
+.CE
+.RE
+.TP
+\fB\-handler\fP \fIcallback\fP
+Invoke \fIcallback\fP whenever HTTP data is available; if present, nothing
+else will be done with the HTTP data. This procedure gets two additional
+arguments: the socket for the HTTP data and the \fItoken\fR returned from
+\fB::http::geturl\fR. The token is the name of a global array that is described
+in the STATE ARRAY section. The procedure is expected to return the number
+of bytes read from the socket. Here is a template for the callback:
+.RS
+.CS
+proc httpHandlerCallback {socket token} {
+ upvar #0 $token state
+ # Access socket, and state as a Tcl array
+ ...
+ (example: set data [read $socket 1000];set nbytes [string length $data])
+ ...
+ return nbytes
+}
+.CE
+.RE
+.TP
+\fB\-headers\fP \fIkeyvaluelist\fP
+This option is used to add extra headers to the HTTP request. The
+\fIkeyvaluelist\fR argument must be a list with an even number of
+elements that alternate between keys and values. The keys become
+header field names. Newlines are stripped from the values so the
+header cannot be corrupted. For example, if \fIkeyvaluelist\fR is
+\fBPragma no-cache\fR then the following header is included in the
+HTTP request:
+.CS
+Pragma: no-cache
+.CE
+.TP
+\fB\-progress\fP \fIcallback\fP
+The \fIcallback\fR is made after each transfer of data from the URL.
+The callback gets three additional arguments: the \fItoken\fR from
+\fB::http::geturl\fR, the expected total size of the contents from the
+\fBContent-Length\fR meta-data, and the current number of bytes
+transferred so far. The expected total size may be unknown, in which
+case zero is passed to the callback. Here is a template for the
+progress callback:
+.RS
+.CS
+proc httpProgress {token total current} {
+ upvar #0 $token state
+}
+.CE
+.RE
+.TP
+\fB\-query\fP \fIquery\fP
+This flag causes \fB::http::geturl\fR to do a POST request that passes the
+\fIquery\fR to the server. The \fIquery\fR must be a x-url-encoding
+formatted query. The \fB::http::formatQuery\fR procedure can be used to
+do the formatting.
+.TP
+\fB\-queryblocksize\fP \fIsize\fP
+The blocksize used when posting query data to the URL.
+At most
+\fIsize\fR
+bytes are written at once. After each block, a call to the
+\fB\-queryprogress\fR
+callback is made (if that option is specified).
+.TP
+\fB\-querychannel\fP \fIchannelID\fP
+This flag causes \fB::http::geturl\fR to do a POST request that passes the
+data contained in \fIchannelID\fR to the server. The data contained in \fIchannelID\fR must be a x-url-encoding
+formatted query unless the \fB\-type\fP option below is used.
+If a Content-Length header is not specified via the \fB\-headers\fR options,
+\fB::http::geturl\fR attempts to determine the size of the post data
+in order to create that header. If it is
+unable to determine the size, it returns an error.
+.TP
+\fB\-queryprogress\fP \fIcallback\fP
+The \fIcallback\fR is made after each transfer of data to the URL
+(i.e. POST) and acts exactly like the \fB\-progress\fR option (the
+callback format is the same).
+.TP
+\fB\-timeout\fP \fImilliseconds\fP
+If \fImilliseconds\fR is non-zero, then \fB::http::geturl\fR sets up a timeout
+to occur after the specified number of milliseconds.
+A timeout results in a call to \fB::http::reset\fP and to
+the \fB-command\fP callback, if specified.
+The return value of \fB::http::status\fP is \fBtimeout\fP
+after a timeout has occurred.
+.TP
+\fB\-type\fP \fImime-type\fP
+Use \fImime-type\fR as the \fBContent-Type\fR value, instead of the
+default value (\fBapplication/x-www-form-urlencoded\fR) during a
+POST operation.
+.TP
+\fB\-validate\fP \fIboolean\fP
+If \fIboolean\fR is non-zero, then \fB::http::geturl\fR does an HTTP HEAD
+request. This request returns meta information about the URL, but the
+contents are not returned. The meta information is available in the
+\fBstate(meta) \fR variable after the transaction. See the STATE
+ARRAY section for details.
+.TP
+\fB\-protocol\fP \fIversion\fP
+Select the HTTP protocol version to use. This can really only be 1.0
+or 1.1. The default is 1.1. Should only be necessary for servers that
+do not understand or otherwise complain about HTTP/1.1.
+.TP
+\fB\-keepalive\fP \fIboolean\fP
+If true, attempt to keep the connection open for servicing multiple
+requests.
+.TP
+\fB\-socketvar\fP \fIvariablename\fP
+Provide a name of a variable to hold the channel used for multiple
+requests. After the first HTTP transaction the named variable will
+contain the channel name. Further requests can be made on the open
+channel until either a request is made with the \fB-keepalive\fR flag
+set to false or until the remote host closes the connection. Once the
+connection is closed the variable will be reset to the empty
+string. See MULTIPLE REQUESTS.
+.RE
+.TP
+\fB::http::formatQuery\fP \fIkey value\fP ?\fIkey value\fP ...?
+This procedure does x-url-encoding of query data. It takes an even
+number of arguments that are the keys and values of the query. It
+encodes the keys and values, and generates one string that has the
+proper & and = separators. The result is suitable for the
+\fB\-query\fR value passed to \fB::http::geturl\fR.
+.TP
+\fB::http::reset\fP \fItoken\fP ?\fIwhy\fP?
+This command resets the HTTP transaction identified by \fItoken\fR, if
+any. This sets the \fBstate(status)\fP value to \fIwhy\fP, which defaults to \fBreset\fR, and then calls the registered \fB\-command\fR callback.
+.TP
+\fB::http::wait\fP \fItoken\fP
+This is a convenience procedure that blocks and waits for the
+transaction to complete. This only works in trusted code because it
+uses \fBvwait\fR. Also, it's not useful for the case where
+\fB::http::geturl\fP is called \fIwithout\fP the \fB-command\fP option
+because in this case the \fB::http::geturl\fP call doesn't return
+until the HTTP transaction is complete, and thus there's nothing to
+wait for.
+.TP
+\fB::http::data\fP \fItoken\fP
+This is a convenience procedure that returns the \fBbody\fP element
+(i.e., the URL data) of the state array.
+.TP
+\fB::http::error\fP \fItoken\fP
+This is a convenience procedure that returns the \fBerror\fP element
+of the state array.
+.TP
+\fB::http::status\fP \fItoken\fP
+This is a convenience procedure that returns the \fBstatus\fP element of
+the state array.
+.TP
+\fB::http::code\fP \fItoken\fP
+This is a convenience procedure that returns the \fBhttp\fP element of the
+state array.
+.TP
+\fB::http::ncode\fP \fItoken\fP
+This is a convenience procedure that returns just the numeric return
+code (200, 404, etc.) from the \fBhttp\fP element of the state array.
+.TP
+\fB::http::size\fP \fItoken\fP
+This is a convenience procedure that returns the \fBcurrentsize\fP
+element of the state array, which represents the number of bytes
+received from the URL in the \fB::http::geturl\fP call.
+.TP
+\fB::http::cleanup\fP \fItoken\fP
+This procedure cleans up the state associated with the connection
+identified by \fItoken\fP. After this call, the procedures
+like \fB::http::data\fP cannot be used to get information
+about the operation. It is \fIstrongly\fP recommended that you call
+this function after you're done with a given HTTP request. Not doing
+so will result in memory not being freed, and if your app calls
+\fB::http::geturl\fP enough times, the memory leak could cause a
+performance hit...or worse.
+.TP
+\fB::http::register\fP \fIproto port command\fP
+This procedure allows one to provide custom HTTP transport types
+such as HTTPS, by registering a prefix, the default port, and the
+command to execute to create the Tcl \fBchannel\fR. E.g.:
+.RS
+.CS
+package require http
+package require tls
+
+http::register https 443 ::tls::socket
+
+set token [http::geturl https://my.secure.site/]
+.CE
+.RE
+.TP
+\fB::http::unregister\fP \fIproto\fP
+This procedure unregisters a protocol handler that was previously
+registered via \fBhttp::register\fR.
+
+.SH "ERRORS"
+The \fBhttp::geturl\fP procedure will raise errors in the following cases:
+invalid command line options,
+an invalid URL,
+a URL on a non-existent host,
+or a URL at a bad port on an existing host.
+These errors mean that it
+cannot even start the network transaction.
+It will also raise an error if it gets an I/O error while
+writing out the HTTP request header.
+For synchronous \fB::http::geturl\fP calls (where \fB-command\fP is
+not specified), it will raise an error if it gets an I/O error while
+reading the HTTP reply headers or data. Because \fB::http::geturl\fP
+doesn't return a token in these cases, it does all the required
+cleanup and there's no issue of your app having to call
+\fB::http::cleanup\fP.
+.PP
+For asynchronous \fB::http::geturl\fP calls, all of the above error
+situations apply, except that if there's any error while
+reading the
+HTTP reply headers or data, no exception is thrown. This is because
+after writing the HTTP headers, \fB::http::geturl\fP returns, and the
+rest of the HTTP transaction occurs in the background. The command
+callback can check if any error occurred during the read by calling
+\fB::http::status\fP to check the status and if it's \fIerror\fP,
+calling \fB::http::error\fP to get the error message.
+.PP
+Alternatively, if the main program flow reaches a point where it needs
+to know the result of the asynchronous HTTP request, it can call
+\fB::http::wait\fP and then check status and error, just as the
+callback does.
+.PP
+In any case, you must still call
+\fBhttp::cleanup\fP to delete the state array when you're done.
+.PP
+There are other possible results of the HTTP transaction
+determined by examining the status from \fBhttp::status\fP.
+These are described below.
+.TP
+ok
+If the HTTP transaction completes entirely, then status will be \fBok\fP.
+However, you should still check the \fBhttp::code\fP value to get
+the HTTP status. The \fBhttp::ncode\fP procedure provides just
+the numeric error (e.g., 200, 404 or 500) while the \fBhttp::code\fP
+procedure returns a value like "HTTP 404 File not found".
+.TP
+eof
+If the server closes the socket without replying, then no error
+is raised, but the status of the transaction will be \fBeof\fP.
+.TP
+error
+The error message will also be stored in the \fBerror\fP status
+array element, accessible via \fB::http::error\fP.
+.PP
+Another error possibility is that \fBhttp::geturl\fP is unable to
+write all the post query data to the server before the server
+responds and closes the socket.
+The error message is saved in the \fBposterror\fP status array
+element and then \fBhttp::geturl\fP attempts to complete the
+transaction.
+If it can read the server's response
+it will end up with an \fBok\fP status, otherwise it will have
+an \fBeof\fP status.
+
+.SH "STATE ARRAY"
+The \fB::http::geturl\fR procedure returns a \fItoken\fR that can be used to
+get to the state of the HTTP transaction in the form of a Tcl array.
+Use this construct to create an easy-to-use array variable:
+.CS
+upvar #0 $token state
+.CE
+Once the data associated with the url is no longer needed, the state
+array should be unset to free up storage.
+The \fBhttp::cleanup\fP procedure is provided for that purpose.
+The following elements of
+the array are supported:
+.RS
+.TP
+\fBbody\fR
+The contents of the URL. This will be empty if the \fB\-channel\fR
+option has been specified. This value is returned by the \fB::http::data\fP command.
+.TP
+\fBcharset\fR
+The value of the charset attribute from the \fBContent-Type\fR meta-data
+value. If none was specified, this defaults to the RFC standard
+\fBiso8859-1\fR, or the value of \fB$::http::defaultCharset\fR. Incoming
+text data will be automatically converted from this charset to utf-8.
+.TP
+\fBcoding\fR
+A copy of the \fBContent-Encoding\fR meta-data value.
+.TP
+\fBcurrentsize\fR
+The current number of bytes fetched from the URL.
+This value is returned by the \fB::http::size\fP command.
+.TP
+\fBerror\fR
+If defined, this is the error string seen when the HTTP transaction
+was aborted.
+.TP
+\fBhttp\fR
+The HTTP status reply from the server. This value
+is returned by the \fB::http::code\fP command. The format of this value is:
+.RS
+.CS
+\fIHTTP/1.0 code string\fP
+.CE
+The \fIcode\fR is a three-digit number defined in the HTTP standard.
+A code of 200 is OK. Codes beginning with 4 or 5 indicate errors.
+Codes beginning with 3 are redirection errors. In this case the
+\fBLocation\fR meta-data specifies a new URL that contains the
+requested information.
+.RE
+.TP
+\fBmeta\fR
+The HTTP protocol returns meta-data that describes the URL contents.
+The \fBmeta\fR element of the state array is a list of the keys and
+values of the meta-data. This is in a format useful for initializing
+an array that just contains the meta-data:
+.RS
+.CS
+array set meta $state(meta)
+.CE
+Some of the meta-data keys are listed below, but the HTTP standard defines
+more, and servers are free to add their own.
+.TP
+\fBContent-Type\fR
+The type of the URL contents. Examples include \fBtext/html\fR,
+\fBimage/gif,\fR \fBapplication/postscript\fR and
+\fBapplication/x-tcl\fR.
+.TP
+\fBContent-Length\fR
+The advertised size of the contents. The actual size obtained by
+\fB::http::geturl\fR is available as \fBstate(size)\fR.
+.TP
+\fBLocation\fR
+An alternate URL that contains the requested data.
+.RE
+.TP
+\fBposterror\fR
+The error, if any, that occurred while writing
+the post query data to the server.
+.TP
+\fBstatus\fR
+Either \fBok\fR, for successful completion, \fBreset\fR for
+user-reset, \fBtimeout\fP if a timeout occurred before the transaction
+could complete, or \fBerror\fR for an error condition. During the
+transaction this value is the empty string.
+.TP
+\fBtotalsize\fR
+A copy of the \fBContent-Length\fR meta-data value.
+.TP
+\fBtype\fR
+A copy of the \fBContent-Type\fR meta-data value.
+.TP
+\fBurl\fR
+The requested URL.
+.RE
+.SH EXAMPLE
+.DS
+# Copy a URL to a file and print meta-data
+proc ::http::copy { url file {chunk 4096} } {
+ set out [open $file w]
+ set token [geturl $url -channel $out -progress ::http::Progress \\
+ -blocksize $chunk]
+ close $out
+ # This ends the line started by http::Progress
+ puts stderr ""
+ upvar #0 $token state
+ set max 0
+ foreach {name value} $state(meta) {
+ if {[string length $name] > $max} {
+ set max [string length $name]
+ }
+ if {[regexp -nocase ^location$ $name]} {
+ # Handle URL redirects
+ puts stderr "Location:$value"
+ return [copy [string trim $value] $file $chunk]
+ }
+ }
+ incr max
+ foreach {name value} $state(meta) {
+ puts [format "%-*s %s" $max $name: $value]
+ }
+
+ return $token
+}
+proc ::http::Progress {args} {
+ puts -nonewline stderr . ; flush stderr
+}
+.DE
+
+.SH "SEE ALSO"
+safe(n), socket(n), safesock(n)
+
+.SH KEYWORDS
+security policy, socket
--- /dev/null
+# http.tcl --
+#
+# Client-side HTTP for GET, POST, and HEAD commands.
+# These routines can be used in untrusted code that uses
+# the Safesock security policy. These procedures use a
+# callback interface to avoid using vwait, which is not
+# defined in the safe base.
+#
+# See the file "license.terms" for information on usage and
+# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id$
+
+# Rough version history:
+# 1.0 Old http_get interface
+# 2.0 http:: namespace and http::geturl
+# 2.1 Added callbacks to handle arriving data, and timeouts
+# 2.2 Added ability to fetch into a channel
+# 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.
+# 2.5 Added HTTP/1.1 support for persistent connections. New options
+# -protocol, -keepalive, -socketvar.
+# 2.6 Added support for HTTP/1.1 extensions. New option -method used
+# for WebDav.
+
+package require Tcl 8.2
+# keep this in sync with pkgIndex.tcl
+package provide http 2.6
+
+namespace eval http {
+ variable http
+ array set http {
+ -accept */*
+ -proxyhost {}
+ -proxyport {}
+ -proxyfilter http::ProxyRequired
+ }
+ set http(-useragent) "Tcl http client package [package provide http]"
+
+ proc init {} {
+ variable formMap
+ variable alphanumeric a-zA-Z0-9
+ for {set i 0} {$i <= 256} {incr i} {
+ set c [format %c $i]
+ if {![string match \[$alphanumeric\] $c]} {
+ set formMap($c) %[format %.2x $i]
+ }
+ }
+ # These are handled specially
+ array set formMap { " " + \n %0d%0a }
+ }
+ init
+
+ variable urlTypes
+ 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
+}
+
+# http::register --
+#
+# See documentation for details.
+#
+# Arguments:
+# proto URL protocol prefix, e.g. https
+# port Default port for protocol
+# command Command to use to create socket
+# Results:
+# list of port and command that was registered.
+
+proc http::register {proto port command} {
+ variable urlTypes
+ set urlTypes($proto) [list $port $command]
+}
+
+# http::unregister --
+#
+# Unregisters URL protocol handler
+#
+# Arguments:
+# proto URL protocol prefix, e.g. https
+# Results:
+# list of port and command that was unregistered.
+
+proc http::unregister {proto} {
+ variable urlTypes
+ if {![info exists urlTypes($proto)]} {
+ return -code error "unsupported url type \"$proto\""
+ }
+ set old $urlTypes($proto)
+ unset urlTypes($proto)
+ return $old
+}
+
+# http::config --
+#
+# See documentation for details.
+#
+# Arguments:
+# args Options parsed by the procedure.
+# Results:
+# TODO
+
+proc http::config {args} {
+ variable http
+ set options [lsort [array names http -*]]
+ set usage [join $options ", "]
+ if {[llength $args] == 0} {
+ set result {}
+ foreach name $options {
+ lappend result $name $http($name)
+ }
+ return $result
+ }
+ regsub -all -- - $options {} options
+ set pat ^-([join $options |])$
+ if {[llength $args] == 1} {
+ set flag [lindex $args 0]
+ if {[regexp -- $pat $flag]} {
+ return $http($flag)
+ } else {
+ return -code error "Unknown option $flag, must be: $usage"
+ }
+ } else {
+ foreach {flag value} $args {
+ if {[regexp -- $pat $flag]} {
+ set http($flag) $value
+ } else {
+ return -code error "Unknown option $flag, must be: $usage"
+ }
+ }
+ }
+}
+
+# http::Finish --
+#
+# Clean up the socket and eval close time callbacks
+#
+# Arguments:
+# token Connection token.
+# errormsg (optional) If set, forces status to error.
+# skipCB (optional) If set, don't call the -command callback. This
+# is useful when geturl wants to throw an exception instead
+# of calling the callback. That way, the same error isn't
+# reported to two places.
+#
+# Side Effects:
+# Closes the socket
+
+proc http::Finish { token {errormsg ""} {skipCB 0}} {
+ variable $token
+ upvar 0 $token state
+ global errorInfo errorCode
+ if {[string length $errormsg] != 0} {
+ set state(error) [list $errormsg $errorInfo $errorCode]
+ set state(status) error
+ }
+ if {[info exists state(-socketvar)] && [info exists $state(-socketvar)]} {
+ set $state(-socketvar) {}
+ }
+ 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} {
+ set state(error) [list $err $errorInfo $errorCode]
+ set state(status) error
+ }
+ }
+ if {[info exist state(-command)]} {
+ # Command callback may already have unset our state
+ unset state(-command)
+ }
+ }
+}
+
+# http::reset --
+#
+# See documentation for details.
+#
+# Arguments:
+# token Connection token.
+# why Status info.
+#
+# Side Effects:
+# See Finish
+
+proc http::reset { token {why reset} } {
+ variable $token
+ upvar 0 $token state
+ set state(status) $why
+ catch {fileevent $state(sock) readable {}}
+ catch {fileevent $state(sock) writable {}}
+ Finish $token
+ if {[info exists state(error)]} {
+ set errorlist $state(error)
+ unset state
+ eval error $errorlist
+ }
+}
+
+# http::geturl --
+#
+# Establishes a connection to a remote url via http.
+#
+# Arguments:
+# url The http URL to goget.
+# 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::geturl { 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 {}
+ -protocol 1.1
+ -keepalive 0
+ -socketvar {}
+ binary false
+ state header
+ meta {}
+ coding {}
+ currentsize 0
+ totalsize 0
+ querylength 0
+ queryoffset 0
+ type text/html
+ body {}
+ status ""
+ http ""
+ }
+ set state(charset) $defaultCharset
+ set options {-binary -blocksize -channel -command -handler -headers \
+ -progress -query -queryblocksize -querychannel -queryprogress\
+ -validate -timeout -type -protocol -keepalive -socketvar\
+ -method}
+ 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"
+ }
+ }
+
+ # Make sure -query and -querychannel aren't both specified
+
+ set isQueryChannel [info exists state(-querychannel)]
+ set isQuery [info exists state(-query)]
+ if {$isQuery && $isQueryChannel} {
+ unset $token
+ return -code error "Can't combine -query and -querychannel options!"
+ }
+
+ # 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 ""
+ }
+
+ # See if we are supposed to use a previously opened channel.
+ if {$state(-socketvar) != {}} {
+ upvar $state(-socketvar) s
+ }
+ if {![info exists s] || $s == {}} {
+
+ # 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 {$isQuery} {
+ set state(querylength) [string length $state(-query)]
+ if {$state(querylength) > 0} {
+ set how POST
+ set contDone 0
+ } else {
+ # there's no query data
+ unset state(-query)
+ set isQuery 0
+ }
+ } elseif {$state(-validate)} {
+ set how HEAD
+ } elseif {$isQueryChannel} {
+ set how POST
+ # The query channel must be blocking for the async Write to
+ # work properly.
+ fconfigure $state(-querychannel) -blocking 1 -translation binary
+ set contDone 0
+ }
+ if {[info exists state(-method)]} {
+ set how $state(-method)
+ }
+ if {[catch {
+ puts $s "$how $srvurl HTTP/$state(-protocol)"
+ puts $s "Accept: $http(-accept)"
+ puts $s "Host: $host:$port"
+ puts $s "User-Agent: $http(-useragent)"
+ if { $state(-protocol) == 1.0 && $state(-keepalive)} {
+ puts $s "Connection: Keep-Alive"
+ }
+ if { $state(-protocol) > 1.0 && ! $state(-keepalive) } {
+ puts $s "Connection: close" ;# RFC2616 sec 8.1.2.1
+ }
+ 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"
+ }
+ }
+ if {$isQueryChannel && $state(querylength) == 0} {
+ # Try to determine size of data in channel
+ # If we cannot seek, the surrounding catch will trap us
+
+ set start [tell $state(-querychannel)]
+ seek $state(-querychannel) 0 end
+ set state(querylength) \
+ [expr {[tell $state(-querychannel)] - $start}]
+ seek $state(-querychannel) $start
+ }
+
+ # 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.
+
+ if {$isQuery || $isQueryChannel} {
+ puts $s "Content-Type: $state(-type)"
+ if {!$contDone} {
+ puts $s "Content-Length: $state(querylength)"
+ }
+ puts $s ""
+ fconfigure $s -translation {auto binary}
+ fileevent $s writable [list http::Write $token]
+ } else {
+ 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
+# Code - the HTTP transaction code, e.g., 200
+# Size - the size of the URL data
+
+proc http::data {token} {
+ variable $token
+ upvar 0 $token state
+ return $state(body)
+}
+proc http::status {token} {
+ variable $token
+ upvar 0 $token state
+ return $state(status)
+}
+proc http::code {token} {
+ variable $token
+ upvar 0 $token state
+ return $state(http)
+}
+proc http::ncode {token} {
+ variable $token
+ upvar 0 $token state
+ if {[regexp {[0-9]{3}} $state(http) numeric_code]} {
+ return $numeric_code
+ } else {
+ return $state(http)
+ }
+}
+proc http::size {token} {
+ variable $token
+ upvar 0 $token state
+ return $state(currentsize)
+}
+
+proc http::error {token} {
+ variable $token
+ upvar 0 $token state
+ if {[info exists state(error)]} {
+ return $state(error)
+ }
+ return ""
+}
+
+# http::cleanup
+#
+# Garbage collect the state associated with a transaction
+#
+# Arguments
+# token The token returned from http::geturl
+#
+# Side Effects
+# unsets the state array
+
+proc http::cleanup {token} {
+ variable $token
+ upvar 0 $token state
+ if {[info exist state]} {
+ unset state
+ }
+}
+
+# http::Connect
+#
+# This callback is made when an asyncronous connection completes.
+#
+# Arguments
+# token The token returned from http::geturl
+#
+# Side Effects
+# Sets the status of the connection, which unblocks
+# the waiting geturl call
+
+proc http::Connect {token} {
+ variable $token
+ upvar 0 $token state
+ global errorInfo errorCode
+ if {[eof $state(sock)] ||
+ [string length [fconfigure $state(sock) -error]]} {
+ Finish $token "connect failed [fconfigure $state(sock) -error]" 1
+ } else {
+ set state(status) connect
+ fileevent $state(sock) writable {}
+ }
+ return
+}
+
+# http::Write
+#
+# Write POST query data to the socket
+#
+# Arguments
+# token The token for the connection
+#
+# Side Effects
+# Write the socket and handle callbacks.
+
+proc http::Write {token} {
+ 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
+
+ puts -nonewline $s \
+ [string range $state(-query) $state(queryoffset) \
+ [expr {$state(queryoffset) + $state(-queryblocksize) - 1}]]
+ incr state(queryoffset) $state(-queryblocksize)
+ if {$state(queryoffset) >= $state(querylength)} {
+ set state(queryoffset) $state(querylength)
+ set done 1
+ }
+ } else {
+
+ # Copy blocks from the query channel
+
+ set outStr [read $state(-querychannel) $state(-queryblocksize)]
+ puts -nonewline $s $outStr
+ incr state(queryoffset) [string length $outStr]
+ if {[eof $state(-querychannel)]} {
+ set done 1
+ }
+ }
+ } err]} {
+ # Do not call Finish here, but instead let the read half of
+ # the socket process whatever server reply there is to get.
+
+ set state(posterror) $err
+ set done 1
+ }
+ if {$done} {
+ catch {flush $s}
+ fileevent $s writable {}
+ fileevent $s readable [list http::Event $token]
+ }
+
+ # Callback to the client after we've completely handled everything
+
+ if {[string length $state(-queryprogress)]} {
+ eval $state(-queryprogress) [list $token $state(querylength)\
+ $state(queryoffset)]
+ }
+}
+
+# http::Event
+#
+# Handle input on the socket
+#
+# Arguments
+# token The token returned from http::geturl
+#
+# Side Effects
+# Read the socket and handle callbacks.
+
+proc http::Event {token} {
+ variable $token
+ upvar 0 $token state
+ set s $state(sock)
+
+ if {[eof $s]} {
+ Eof $token 1
+ return
+ }
+ if {[string equal $state(state) "header"]} {
+ if {[catch {gets $s line} n]} {
+ Finish $token $n
+ } elseif {$n == 0} {
+ # We ignore HTTP/1.1 100 Continue returns. RFC2616 sec 8.2.3
+ if {[lindex $state(http) 1] == 100} {
+ return
+ }
+ set state(state) body
+ fconfigure $s -translation binary
+ if {$state(-binary) || ![regexp -nocase ^text $state(type)] || \
+ [regexp gzip|compress $state(coding)]} {
+ # Turn off conversions for non-text data
+ set state(binary) true
+ if {[info exists state(-channel)]} {
+ fconfigure $state(-channel) -translation binary
+ }
+ }
+ 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]
+ # grab the optional charset information
+ regexp -nocase {charset\s*=\s*(\S+)} $type x state(charset)
+ }
+ 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 {^([^:]+):(.+)$} $line x key value]} {
+ lappend state(meta) $key [string trim $value]
+ } 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
+ }
+ # If Content-Length - check for end of data.
+ if {$state(totalsize) > 0 \
+ && $state(currentsize) >= $state(totalsize)} {
+ Eof $token
+ }
+ } err]} {
+ Finish $token $err
+ } else {
+ if {[info exists state(-progress)]} {
+ eval $state(-progress) \
+ {$token $state(totalsize) $state(currentsize)}
+ }
+ }
+ }
+}
+
+# http::CopyStart
+#
+# Error handling wrapper around fcopy
+#
+# Arguments
+# s The socket to copy from
+# token The token returned from http::geturl
+#
+# Side Effects
+# This closes the connection upon error
+
+proc http::CopyStart {s token} {
+ variable $token
+ upvar 0 $token state
+ if {[catch {
+ fcopy $s $state(-channel) -size $state(-blocksize) -command \
+ [list http::CopyDone $token]
+ } err]} {
+ Finish $token $err
+ }
+}
+
+# http::CopyDone
+#
+# fcopy completion callback
+#
+# Arguments
+# token The token returned from http::geturl
+# count The amount transfered
+#
+# Side Effects
+# Invokes callbacks
+
+proc http::CopyDone {token count {error {}}} {
+ variable $token
+ upvar 0 $token state
+ set s $state(sock)
+ incr state(currentsize) $count
+ if {[info exists state(-progress)]} {
+ eval $state(-progress) {$token $state(totalsize) $state(currentsize)}
+ }
+ # At this point the token may have been reset
+ if {[string length $error]} {
+ Finish $token $error
+ } elseif {[catch {eof $s} iseof] || $iseof} {
+ Eof $token
+ } else {
+ CopyStart $s $token
+ }
+}
+
+# http::Eof
+#
+# Handle eof on the socket
+#
+# Arguments
+# token The token returned from http::geturl
+#
+# Side Effects
+# Clean up the socket
+
+proc http::Eof {token {force 0}} {
+ variable $token
+ upvar 0 $token state
+ if {[string equal $state(state) "header"]} {
+ # Premature eof
+ set state(status) eof
+ } else {
+ set state(status) ok
+ }
+
+ if {! $state(binary)} {
+
+ # If we are getting text, set the data'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.
+
+ variable encodings
+ set idx [lsearch -exact $encodings \
+ [string tolower $state(charset)]]
+ if {$idx >= 0} {
+ set state(body) [encoding convertfrom \
+ [lindex $encodings $idx] \
+ $state(body)]
+ }
+
+ # Translate text line endings
+ set state(body) [string map {\r\n \n \r \n} $state(body)]
+ }
+
+ set state(state) eof
+ if {$state(-keepalive) && ! $force} {
+ catch {after cancel $state(after)}
+ } else {
+ Finish $token
+ }
+}
+
+# http::wait --
+#
+# See documentation for details.
+#
+# Arguments:
+# token Connection token.
+#
+# Results:
+# The status after the wait.
+
+proc http::wait {token} {
+ variable $token
+ upvar 0 $token state
+
+ if {![info exists state(status)] || [string length $state(status)] == 0} {
+ # We must wait on the original variable name, not the upvar alias
+ vwait $token\(status)
+ }
+
+ return $state(status)
+}
+
+# http::formatQuery --
+#
+# See documentation for details.
+# Call http::formatQuery with an even number of arguments, where
+# the first is a name, the second is a value, the third is another
+# name, and so on.
+#
+# Arguments:
+# args A list of name-value pairs.
+#
+# Results:
+# TODO
+
+proc http::formatQuery {args} {
+ set result ""
+ set sep ""
+ foreach i $args {
+ append result $sep [mapReply $i]
+ if {[string equal $sep "="]} {
+ set sep &
+ } else {
+ set sep =
+ }
+ }
+ return $result
+}
+
+# http::mapReply --
+#
+# Do x-www-urlencoded character mapping
+#
+# Arguments:
+# string The string the needs to be encoded
+#
+# Results:
+# The encoded string
+
+proc http::mapReply {string} {
+ 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
+
+ regsub -all \[^$alphanumeric\] $string {$formMap(&)} string
+ regsub -all {[][{})\\]\)} $string {\\&} string
+ return [subst -nocommand $string]
+}
+
+# http::ProxyRequired --
+# Default proxy filter.
+#
+# Arguments:
+# host The destination host
+#
+# Results:
+# The current proxy settings
+
+proc http::ProxyRequired {host} {
+ variable http
+ if {[info exists http(-proxyhost)] && [string length $http(-proxyhost)]} {
+ if {![info exists http(-proxyport)] || \
+ ![string length $http(-proxyport)]} {
+ set http(-proxyport) 8080
+ }
+ return [list $http(-proxyhost) $http(-proxyport)]
+ }
+}
--- /dev/null
+# Tcl package index file, version 1.1
+# This file is generated by the "pkg_mkIndex" command
+# and sourced either when an application starts up or
+# by a "package unknown" script. It invokes the
+# "package ifneeded" command to set up package-related
+# information so that packages will be loaded automatically
+# in response to "package require" commands. When this
+# script is sourced, the variable $dir must contain the
+# full path name of this file's directory.
+
+if {![package vsatisfies [package provide Tcl] 8.2]} {return}
+package ifneeded http 2.6 [list tclPkgSetup $dir http 2.6 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister}}}]
package require vfs 1.0
-package require http
+package require http 2.6
# part of tcllib
package require base64
-# This works for very basic operations (cd, open, file stat, but not 'glob').
+# This works for very basic operations.
# It has been put together, so far, largely by trial and error!
+# What it really needs is to be filled in with proper xml support,
+# using the tclxml package.
namespace eval vfs::webdav {}
set dirurl "http://$host/$path"
- set extraHeadersList "Authorization {Basic [base64::encode ${user}:${pass}]}"
+ set extraHeadersList [list Authorization {Basic [base64::encode ${user}:${pass}]}]
set token [::http::geturl $dirurl -headers $extraHeadersList -validate 1]
http::cleanup $token
# This is a bit of a hack. We really want to do a 'PROPFIND'
# request with depth 0, I believe. I don't think Tcl's http
# package supports that.
- set token [::http::geturl $dirurl$name -headers $extraHeadersList]
+ set token [::http::geturl $dirurl$name -method PROPFIND \
+ -headers [concat $extraHeadersList [list depth 0]]
upvar #0 $token state
- if {![regexp " (OK|Moved Permanently)$" $state(http)]} {
+ if {![regexp " OK$" $state(http)]} {
::vfs::log "No good: $state(http)"
::http::cleanup $token
error "Not found"
}
- if {[regexp "Moved Permanently$" $state(http)]} {
- regexp {<A HREF="([^"]+)">here</A>} $state(body) -> here
- if {[string index $here end] == "/"} {
- set type directory
- }
- }
- if {![info exists type]} {
+ regexp {<D:prop>(.*)</D:prop>} [::http::data $token] -> properties
+ if {[regexp {<D:resourcetype><D:collection/>} $properties]} {
+ set type directory
+ } else {
set type file
}
}
proc vfs::webdav::matchindirectory {dirurl extraHeadersList path actualpath pattern type} {
- ::vfs::log "matchindirectory $path $pattern $type"
+ ::vfs::log "matchindirectory $dirurl $path $pattern $type"
set res [list]
- puts stderr "The 'PROPFIND' method not implemented. Please help!"
-
if {[string length $pattern]} {
# need to match all files in a given remote http site.
-
+ set token [::http::geturl $dirurl$path -method PROPFIND \
+ -headers [concat $extraHeadersList [list depth 1]]]
+ upvar #0 $token state
+ #parray state
+
+ set body [::http::data $token]
+ ::http::cleanup $token
+ ::vfs::log $body
+ while {1} {
+ if {![regexp "(<D:response.*</D:response>)(.*)" $body -> item body]} {
+ # No more files
+ break
+ }
+ if {![regexp "<D:href>(.*)</D:href>" $item -> name]} {
+ continue
+ }
+ # Get tail of name (don't use 'file tail' since it isn't a file).
+ regexp {[^/]+$} $name name
+
+ if {[string match $pattern $name]} {
+ eval lappend res [_matchtypes $item $actualpath $type]
+ }
+ }
} else {
# single file
- if {![catch {access $dirurl $path}]} {
- lappend res $path
- }
+ set token [::http::geturl $dirurl$path -method PROPFIND \
+ -headers [concat $extraHeadersList [list depth 0]]]
+
+ set body [::http::data $token]
+ ::http::cleanup $token
+ ::vfs::log $body
+
+ eval lappend res [_matchtypes $body $actualpath $type]
}
return $res
}
+# Helper function
+proc vfs::webdav::_matchtypes {item actualpath type} {
+ if {[regexp {<D:resourcetype><D:collection/>} $item]} {
+ if {![::vfs::matchDirectories $type]} {
+ return ""
+ }
+ } else {
+ if {![::vfs::matchFiles $type]} {
+ return ""
+ }
+ }
+ return [list $actualpath]
+}
+
proc vfs::webdav::createdirectory {dirurl extraHeadersList name} {
::vfs::log "createdirectory $name"
- error "read-only"
+ error "write access not implemented"
}
proc vfs::webdav::removedirectory {dirurl extraHeadersList name} {
::vfs::log "removedirectory $name"
- error "read-only"
+ error "write access not implemented"
}
proc vfs::webdav::deletefile {dirurl extraHeadersList name} {
::vfs::log "deletefile $name"
- error "read-only"
+ error "write access not implemented"
}
proc vfs::webdav::fileattributes {dirurl extraHeadersList path args} {
# set value
set index [lindex $args 0]
set val [lindex $args 1]
- error "read-only"
+ error "write access not implemented"
}
}
}
proc vfs::webdav::utime {dirurl extraHeadersList path actime mtime} {
- error "Can't set utime"
+ error "write access not implemented"
}
DLL_VERSION = 10
# comment the following line to compile with symbols
-NODEBUG=1
+NODEBUG=0
!IF "$(NODEBUG)" == "1"
DEBUGDEFINES =
projects / tclvfs / commitdiff