Tcl Source Code

'\"
'\" Copyright (c) 2014-2018 Donal K. Fellows.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.TH "cookiejar" n 0.1 http "Tcl Bundled Packages"
.so man.macros
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
cookiejar \- Implementation of the Tcl http package cookie jar protocol
.SH SYNOPSIS
.nf
\fBpackage require\fR \fBcookiejar\fR ?\fB0.1\fR?

\fB::http::cookiejar configure\fR ?\fIoptionName\fR? ?\fIoptionValue\fR?
\fB::http::cookiejar create\fR \fIname\fR ?\fIfilename\fR?
\fB::http::cookiejar new\fR ?\fIfilename\fR?

\fIcookiejar\fR \fBdestroy\fR
\fIcookiejar\fR \fBforceLoadDomainData\fR
\fIcookiejar\fR \fBgetCookies\fR \fIprotocol host path\fR
\fIcookiejar\fR \fBstoreCookie\fR \fIoptions\fR
\fIcookiejar\fR \fBlookup\fR ?\fIhost\fR? ?\fIkey\fR?
.fi
.SH DESCRIPTION
.PP
The cookiejar package provides an implementation of the http package's cookie
jar protocol using an SQLite database. It provides one main command,
\fB::http::cookiejar\fR, which is a TclOO class that should be instantiated to
create a cookie jar that manages a particular HTTP session.
.PP
The database management policy can be controlled at the package level by the
\fBconfigure\fR method on the \fB::http::cookiejar\fR class object:
.TP
\fB::http::cookiejar configure\fR ?\fIoptionName\fR? ?\fIoptionValue\fR?
.
If neither \fIoptionName\fR nor \fIoptionValue\fR are supplied, this returns a
copy of the configuration as a Tcl dictionary. If just \fIoptionName\fR is
supplied, just the value of the named option is returned. If both
\fIoptionName\fR and \fIoptionValue\fR are given, the named option is changed
to be the given value.
.RS
.PP
Supported options are:
.TP
\fB\-domainfile \fIfilename\fR
.
A file (defaulting to within the cookiejar package) with a description of the
list of top-level domains (e.g., \fB.com\fR or \fB.co.jp\fR). Such domains
\fImust not\fR accept cookies set upon them. Note that the list of such
domains is both security-sensitive and \fInot\fR constant and should be
periodically refetched. Cookie jars maintain their own cache of the domain
list.
.TP
\fB\-domainlist \fIurl\fR
.
A URL to fetch the list of top-level domains (e.g., \fB.com\fR or
\fB.co.jp\fR) from.  Such domains \fImust not\fR accept cookies set upon
them. Note that the list of such domains is both security-sensitive and
\fInot\fR constant and should be periodically refetched. Cookie jars maintain
their own cache of the domain list.
.TP
\fB\-domainrefresh \fIintervalMilliseconds\fR
.
The number of milliseconds between checks of the \fI\-domainlist\fR for new
domains.
.TP
\fB\-loglevel \fIlevel\fR
.
The logging level of this package. The logging level must be (in order of
decreasing verbosity) one of \fBdebug\fR, \fBinfo\fR, \fBwarn\fR, or
\fBerror\fR.
.TP
\fB\-offline \fIflag\fR
.
Allows the cookie managment engine to be placed into offline mode. In offline
mode, the list of domains is read immediately from the file configured in the
\fB\-domainfile\fR option, and the \fB\-domainlist\fR option is not used; it
also makes the \fB\-domainrefresh\fR option be effectively ignored.
.TP
\fB\-purgeold \fIintervalMilliseconds\fR
.
The number of milliseconds between checks of the database for expired
cookies; expired cookies are deleted.
.TP
\fB\-retain \fIcookieCount\fR
.
The maximum number of cookies to retain in the database.
.TP
\fB\-vacuumtrigger \fIdeletionCount\fR
.
A count of the number of persistent cookie deletions to go between vacuuming
the database.
.RE
.PP
Cookie jar instances may be made with any of the standard TclOO instance
creation methods (\fBcreate\fR or \fRnew\fR).
.TP
\fB::http::cookiejar new\fR ?\fIfilename\fR?
.
If a \fIfilename\fR argument is provided, it is the name of a file containing
an SQLite database that will contain the persistent cookies maintained by the
cookie jar; the database will be created if the file does not already
exist. If \fIfilename\fR is not supplied, the database will be held entirely within
memory, which effectively forces all cookies within it to be session cookies.
.SS "INSTANCE METHODS"
.PP
The following methods are supported on the instances:
.TP
\fIcookiejar\fR \fBdestroy\fR
.
This is the standard TclOO destruction method. It does \fInot\fR delete the
SQLite database if it is written to disk. Callers are responsible for ensuring
that the cookie jar is not in use by the http package at the time of
destruction.
.TP
\fIcookiejar\fR \fBforceLoadDomainData\fR
.
This method causes the cookie jar to immediately load (and cache) the domain
list data. The domain list will be loaded from the \fB\-domainlist\fR
configured a the package level if that is enabled, and otherwise will be
obtained from the \fB\-domainfile\fR configured at the package level.
.TP
\fIcookiejar\fR \fBgetCookies\fR \fIprotocol host path\fR
.
This method obtains the cookies for a particular HTTP request. \fIThis
implements the http cookie jar protocol.\fR
.TP
\fIcookiejar\fR \fBpolicyAllow\fR \fIoperation domain path\fR
.
This method is called by the \fBstoreCookie\fR method to get a decision on
whether to allow \fIoperation\fR to be performed for the \fIdomain\fR and
\fIpath\fR. This is checked immediately before the database is updated but
after the built-in security checks are done, and should return a boolean
value; if the value is false, the operation is rejected and the database is
not modified. The supported \fIoperation\fRs are:
.RS
.TP
\fBdelete\fR
.
The \fIdomain\fR is seeking to delete a cookie.
.TP
\fBsession\fR
.
The \fIdomain\fR is seeking to create or update a session cookie.
.TP
\fBset\fR
.
The \fIdomain\fR is seeking to create or update a persistent cookie (with a
defined lifetime).
.PP
The default implementation of this method just returns true, but subclasses of
this class may impose their own rules.
.RE
.TP
\fIcookiejar\fR \fBstoreCookie\fR \fIoptions\fR
.
This method stores a single cookie from a particular HTTP response. Cookies
that fail security checks are ignored. \fIThis implements the http cookie jar
protocol.\fR
.TP
\fIcookiejar\fR \fBlookup\fR ?\fIhost\fR? ?\fIkey\fR?
.
This method looks a cookie by exact host (or domain) matching. If neither
\fIhost\fR nor \fIkey\fR are supplied, the list of hosts for which a cookie is
stored is returned. If just \fIhost\fR (which may be a hostname or a domain
name) is supplied, the list of cookie keys stored for that host is returned.
If both \fIhost\fR and \fIkey\fR are supplied, the value for that key is
returned; it is an error if no such host or key match exactly.
.SH "EXAMPLES"
.PP
The simplest way of using a cookie jar is to just permanently configure it at
the start of the application.
.PP
.CS
package require http
\fBpackage require cookiejar\fR

set cookiedb ~/.tclcookies.db
http::configure -cookiejar [\fBhttp::cookiejar new\fR $cookiedb]

# No further explicit steps are required to use cookies
set tok [http::geturl http://core.tcl.tk/]
.CE
.PP
To only allow a particular domain to use cookies, perhaps because you only
want to enable a particular host to create and manipulate sessions, create a
subclass that imposes that policy.
.PP
.CS
package require http
\fBpackage require cookiejar\fR

oo::class create MyCookieJar {
    superclass \fBhttp::cookiejar\fR

    method \fBpolicyAllow\fR {operation domain path} {
        return [expr {$domain eq "my.example.com"}]
    }
}

set cookiedb ~/.tclcookies.db
http::configure -cookiejar [MyCookieJar new $cookiedb]

# No further explicit steps are required to use cookies
set tok [http::geturl http://core.tcl.tk/]
.CE
.SH "SEE ALSO"
http(n), oo::class(n), sqlite3(n)
.SH KEYWORDS
cookie, internet, security policy, www
'\" Local Variables:
'\" mode: nroff
'\" fill-column: 78
'\" End:

\fB\-accept\fR \fImimetypes\fR
.
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,
.QW "image/gif, image/jpeg, text/*" .
.TP
\fB\-cookiejar\fR \fIcommand\fR
.VS TIP406
The cookie store for the package to use to manage HTTP cookies.
\fIcommand\fR is a command prefix list; if the empty list (the
default value) is used, no cookies will be sent by requests or stored
from responses. The command indicated by \fIcommand\fR, if supplied,
must obey the \fBCOOKIE JAR PROTOCOL\fR described below.
.VE TIP406
.TP
\fB\-pipeline\fR \fIboolean\fR
.
Specifies whether HTTP/1.1 transactions on a persistent socket will be
pipelined.  See the \fBPERSISTENT SOCKETS\fR section for details. The default
is 1.
.TP

half-closed (an
.QW "asynchronous close event" ).
Subsequent GET and HEAD requests in a failed pipeline will also be retried.
\fIThe -repost option should be used only if the application understands
that the retry is appropriate\fR - specifically, the application must know
that if the failed POST successfully modified the state of the server, a repeat POST
would have no adverse effect.
.VS TIP406
.SH "COOKIE JAR PROTOCOL"
.PP
Cookies are short key-value pairs used to implement sessions within the
otherwise-stateless HTTP protocol. (See RFC 6265 for details; Tcl does not
implement the Cookie2 protocol as that is rarely seen in the wild.)
.PP
Cookie storage managment commands \(em
.QW "cookie jars"
\(em must support these subcommands which form the HTTP cookie storage
management protocol. Note that \fIcookieJar\fR below does not have to be a
command name; it is properly a command prefix (a Tcl list of words that will
be expanded in place) and admits many possible implementations.
.PP
Though not formally part of the protocol, it is expected that particular
values of \fIcookieJar\fR will correspond to sessions; it is up to the caller
of \fB::http::config\fR to decide what session applies and to manage the
deletion of said sessions when they are no longer desired (which should be
when they not configured as the current cookie jar).
.TP
\fIcookieJar \fBgetCookies \fIprotocol host requestPath\fR
.
This command asks the cookie jar what cookies should be supplied for a
particular request. It should take the \fIprotocol\fR (typically \fBhttp\fR or
\fBhttps\fR), \fIhost\fR name and \fIrequestPath\fR (parsed from the \fIurl\fR
argument to \fB::http::geturl\fR) and return a list of cookie keys and values
that describe the cookies to supply to the remote host. The list must have an
even number of elements.
.RS
.PP
There should only ever be at most one cookie with a particular key for any
request (typically the one with the most specific \fIhost\fR/domain match and
most specific \fIrequestPath\fR/path match), but there may be many cookies
with different names in any request.
.RE
.TP
\fIcookieJar \fBstoreCookie \fIcookieDictionary\fR
.
This command asks the cookie jar to store a particular cookie that was
returned by a request; the result of this command is ignored. The cookie
(which will have been parsed by the http package) is described by a
dictionary, \fIcookieDictionary\fR, that may have the following keys:
.RS
.TP
\fBdomain\fR
.
This is always present. Its value describes the domain hostname \fIor
prefix\fR that the cookie should be returned for.  The checking of the domain
against the origin (below) should be careful since sites that issue cookies
should only do so for domains related to themselves. Cookies that do not obey
a relevant origin matching rule should be ignored.
.TP
\fBexpires\fR
.
This is optional. If present, the cookie is intended to be a persistent cookie
and the value of the option is the Tcl timestamp (in seconds from the same
base as \fBclock seconds\fR) of when the cookie expires (which may be in the
past, which should result in the cookie being deleted immediately). If absent,
the cookie is intended to be a session cookie that should be not persisted
beyond the lifetime of the cookie jar.
.TP
\fBhostonly\fR
.
This is always present. Its value is a boolean that describes whether the
cookie is a single host cookie (true) or a domain-level cookie (false).
.TP
\fBhttponly\fR
.
This is always present. Its value is a boolean that is true when the site
wishes the cookie to only ever be used with HTTP (or HTTPS) traffic.
.TP
\fBkey\fR
.
This is always present. Its value is the \fIkey\fR of the cookie, which is
part of the information that must be return when sending this cookie back in a
future request.
.TP
\fBorigin\fR
.
This is always present. Its value describes where the http package believes it
received the cookie from, which may be useful for checking whether the
cookie's domain is valid.
.TP
\fBpath\fR
.
This is always present. Its value describes the path prefix of requests to the
cookie domain where the cookie should be returned.
.TP
\fBsecure\fR
.
This is always present. Its value is a boolean that is true when the cookie
should only used on requests sent over secure channels (typically HTTPS).
.TP
\fBvalue\fR
.
This is always present. Its value is the value of the cookie, which is part of
the information that must be return when sending this cookie back in a future
request.
.PP
Other keys may always be ignored; they have no meaning in this protocol.
.RE
.VE TIP406
.SH EXAMPLE
.PP
This example creates a procedure to copy a URL to a file while printing a
progress meter, and prints the meta-data associated with the URL.
.PP
.CS
proc httpcopy { url file {chunk 4096} } {

'\"
'\" Copyright (c) 2014-2018 Donal K. Fellows.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.TH "idna" n 0.1 http "Tcl Bundled Packages"
.so man.macros
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
tcl::idna \- Support for normalization of Internationalized Domain Names
.SH SYNOPSIS
.nf
package require tcl::idna 1.0

\fBtcl::idna decode\fR \fIhostname\fR
\fBtcl::idna encode\fR \fIhostname\fR
\fBtcl::idna puny decode\fR \fIstring\fR ?\fIcase\fR?
\fBtcl::idna puny encode\fR \fIstring\fR ?\fIcase\fR?
\fBtcl::idna version\fR
.fi
.SH DESCRIPTION
This package provides an implementation of the punycode scheme used in
Internationalised Domain Names, and some access commands. (See RFC 3492 for a
description of punycode.)
.TP
\fBtcl::idna decode\fR \fIhostname\fR
.
This command takes the name of a host that potentially contains
punycode-encoded character sequences, \fIhostname\fR, and returns the hostname
as might be displayed to the user. Note that there are often UNICODE
characters that have extremely similar glyphs, so care should be taken with
displaying hostnames to users.
.TP
\fBtcl::idna encode\fR \fIhostname\fR
.
This command takes the name of a host as might be displayed to the user,
\fIhostname\fR, and returns the version of the hostname with characters not
permitted in basic hostnames encoded with punycode.
.TP
\fBtcl::idna puny\fR \fIsubcommand ...\fR
.
This command provides direct access to the basic punycode encoder and
decoder. It supports two \fIsubcommand\fRs:
.RS
.TP
\fBtcl::idna puny decode\fR \fIstring\fR ?\fIcase\fR?
.
This command decodes the punycode-encoded string, \fIstring\fR, and returns
the result. If \fIcase\fR is provided, it is a boolean to make the case be
folded to upper case (if \fIcase\fR is true) or lower case (if \fIcase\fR is
false) during the decoding process; if omitted, no case transformation is
applied.
.TP
\fBtcl::idna puny encode\fR \fIstring\fR ?\fIcase\fR?
.
This command encodes the string, \fIstring\fR, and returns the
punycode-encoded version of the string. If \fIcase\fR is provided, it is a
boolean to make the case be folded to upper case (if \fIcase\fR is true) or
lower case (if \fIcase\fR is false) during the encoding process; if omitted,
no case transformation is applied.
.RE
.TP
\fBtcl::idna version\fR
.
This returns the version of the \fBtcl::idna\fR package.
.SH "EXAMPLE"
.PP
This is an example of how punycoding of a string works:
.PP
.CS
package require tcl::idna

puts [\fBtcl::idna puny encode\fR "abc\(->def"]
#    prints: \fIabcdef-kn2c\fR
puts [\fBtcl::idna puny decode\fR "abcdef-kn2c"]
#    prints: \fIabc\(->def\fR
.CE
'\" TODO: show how it handles a real domain name
.SH "SEE ALSO"
http(n), cookiejar(n)
.SH KEYWORDS
internet, www
'\" Local Variables:
'\" mode: nroff
'\" fill-column: 78
'\" End:

# cookiejar.tcl --
#
#	Implementation of an HTTP cookie storage engine using SQLite. The
#	implementation is done as a TclOO class, and includes a punycode
#	encoder and decoder (though only the encoder is currently used).
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.

# Dependencies
package require Tcl 8.6
package require http 2.8.4
package require sqlite3
package require tcl::idna 1.0

#
# Configuration for the cookiejar package, plus basic support procedures.
#

# This is the class that we are creating
if {![llength [info commands ::http::cookiejar]]} {
    ::oo::class create ::http::cookiejar
}

namespace eval [info object namespace ::http::cookiejar] {
    proc setInt {*var val} {
	upvar 1 ${*var} var
	if {[catch {incr dummy $val} msg]} {
	    return -code error $msg
	}
	set var $val
    }
    proc setInterval {trigger *var val} {
	upvar 1 ${*var} var
	if {![string is integer -strict $val] || $val < 1} {
	    return -code error "expected positive integer but got \"$val\""
	}
	set var $val
	{*}$trigger
    }
    proc setBool {*var val} {
	upvar 1 ${*var} var
	if {[catch {if {$val} {}} msg]} {
	    return -code error $msg
	}
	set var [expr {!!$val}]
    }

    proc setLog {*var val} {
	upvar 1 ${*var} var
	set var [::tcl::prefix match -message "log level" \
		{debug info warn error} $val]
    }

    # Keep this in sync with pkgIndex.tcl and with the install directories in
    # Makefiles
    variable version 0.1

    variable domainlist \
	http://publicsuffix.org/list/effective_tld_names.dat
    variable domainfile \
	[file join [file dirname [info script]] effective_tld_names.txt.gz]
    # The list is directed to from http://publicsuffix.org/list/
    variable loglevel info
    variable vacuumtrigger 200
    variable retainlimit 100
    variable offline false
    variable purgeinterval 60000
    variable refreshinterval 10000000
    variable domaincache {}

    # Some support procedures, none particularly useful in general
    namespace eval support {
	# Set up a logger if the http package isn't actually loaded yet.
	if {![llength [info commands ::http::Log]]} {
	    proc ::http::Log args {
		# Do nothing by default...
	    }
	}

	namespace export *
	proc locn {secure domain path {key ""}} {
	    if {$key eq ""} {
		format "%s://%s%s" [expr {$secure?"https":"http"}] \
		    [::tcl::idna encode $domain] $path
	    } else {
		format "%s://%s%s?%s" \
		    [expr {$secure?"https":"http"}] [::tcl::idna encode $domain] \
		    $path $key
	    }
	}
	proc splitDomain domain {
	    set pieces [split $domain "."]
	    for {set i [llength $pieces]} {[incr i -1] >= 0} {} {
		lappend result [join [lrange $pieces $i end] "."]
	    }
	    return $result
	}
	proc splitPath path {
	    set pieces [split [string trimleft $path "/"] "/"]
	    for {set j -1} {$j < [llength $pieces]} {incr j} {
		lappend result /[join [lrange $pieces 0 $j] "/"]
	    }
	    return $result
	}
	proc isoNow {} {
	    set ms [clock milliseconds]
	    set ts [expr {$ms / 1000}]
	    set ms [format %03d [expr {$ms % 1000}]]
	    clock format $ts -format "%Y%m%dT%H%M%S.${ms}Z" -gmt 1
	}
	proc log {level msg args} {
	    namespace upvar [info object namespace ::http::cookiejar] \
		loglevel loglevel
	    set who [uplevel 1 self class]
	    set mth [uplevel 1 self method]
	    set map {debug 0 info 1 warn 2 error 3}
	    if {[string map $map $level] >= [string map $map $loglevel]} {
		set msg [format $msg {*}$args]
		set LVL [string toupper $level]
		::http::Log "[isoNow] $LVL $who $mth - $msg"
	    }
	}
    }
}

# Now we have enough information to provide the package.
package provide cookiejar \
    [set [info object namespace ::http::cookiejar]::version]

# The implementation of the cookiejar package
::oo::define ::http::cookiejar {
    self {
	method configure {{optionName "\u0000\u0000"} {optionValue "\u0000\u0000"}} {
	    set tbl {
		-domainfile    {domainfile set}
		-domainlist    {domainlist set}
		-domainrefresh {refreshinterval setInterval}
		-loglevel      {loglevel setLog}
		-offline       {offline setBool}
		-purgeold      {purgeinterval setInterval}
		-retain        {retainlimit setInt}
		-vacuumtrigger {vacuumtrigger setInt}
	    }
	    dict lappend tbl -domainrefresh [namespace code {
		my IntervalTrigger PostponeRefresh
	    }]
	    dict lappend tbl -purgeold [namespace code {
		my IntervalTrigger PostponePurge
	    }]
	    if {$optionName eq "\u0000\u0000"} {
		return [dict keys $tbl]
	    }
	    set opt [::tcl::prefix match -message "option" \
		    [dict keys $tbl] $optionName]
	    set setter [lassign [dict get $tbl $opt] varname]
	    namespace upvar [namespace current] $varname var
	    if {$optionValue ne "\u0000\u0000"} {
		{*}$setter var $optionValue
	    }
	    return $var
	}

	method IntervalTrigger {method} {
	    # TODO: handle subclassing
	    foreach obj [info class instances [self]] {
		[info object namespace $obj]::my $method
	    }
	}
    }

    variable purgeTimer deletions refreshTimer
    constructor {{path ""}} {
	namespace import [info object namespace [self class]]::support::*

	if {$path eq ""} {
	    sqlite3 [namespace current]::db :memory:
	    set storeorigin "constructed cookie store in memory"
	} else {
	    sqlite3 [namespace current]::db $path
	    db timeout 500
	    set storeorigin "loaded cookie store from $path"
	}

	set deletions 0
	db transaction {
	    db eval {
		--;# Store the persistent cookies in this table.
		--;# Deletion policy: once they expire, or if explicitly
		--;# killed.
		CREATE TABLE IF NOT EXISTS persistentCookies (
		    id INTEGER PRIMARY KEY,
		    secure INTEGER NOT NULL,
		    domain TEXT NOT NULL COLLATE NOCASE,
		    path TEXT NOT NULL,
		    key TEXT NOT NULL,
		    value TEXT NOT NULL,
		    originonly INTEGER NOT NULL,
		    expiry INTEGER NOT NULL,
		    lastuse INTEGER NOT NULL,
		    creation INTEGER NOT NULL);
		CREATE UNIQUE INDEX IF NOT EXISTS persistentUnique
		    ON persistentCookies (domain, path, key);
		CREATE INDEX IF NOT EXISTS persistentLookup
		    ON persistentCookies (domain, path);

		--;# Store the session cookies in this table.
		--;# Deletion policy: at cookiejar instance deletion, if
		--;# explicitly killed, or if the number of session cookies is
		--;# too large and the cookie has not been used recently.
		CREATE TEMP TABLE sessionCookies (
		    id INTEGER PRIMARY KEY,
		    secure INTEGER NOT NULL,
		    domain TEXT NOT NULL COLLATE NOCASE,
		    path TEXT NOT NULL,
		    key TEXT NOT NULL,
		    originonly INTEGER NOT NULL,
		    value TEXT NOT NULL,
		    lastuse INTEGER NOT NULL,
		    creation INTEGER NOT NULL);
		CREATE UNIQUE INDEX sessionUnique
		    ON sessionCookies (domain, path, key);
		CREATE INDEX sessionLookup ON sessionCookies (domain, path);

		--;# View to allow for simple looking up of a cookie.
		--;# Deletion policy: NOT SUPPORTED via this view.
		CREATE TEMP VIEW cookies AS
		    SELECT id, domain, (
			    CASE originonly WHEN 1 THEN path ELSE '.' || path END
			) AS path, key, value, secure, 1 AS persistent
			FROM persistentCookies
		    UNION
		    SELECT id, domain, (
			    CASE originonly WHEN 1 THEN path ELSE '.' || path END
			) AS path, key, value, secure, 0 AS persistent
			FROM sessionCookies;

		--;# Encoded domain permission policy; if forbidden is 1, no
		--;# cookie may be ever set for the domain, and if forbidden
		--;# is 0, cookies *may* be created for the domain (overriding
		--;# the forbiddenSuper table).
		--;# Deletion policy: normally not modified.
		CREATE TABLE IF NOT EXISTS domains (
		    domain TEXT PRIMARY KEY NOT NULL,
		    forbidden INTEGER NOT NULL);

		--;# Domains that may not have a cookie defined for direct
		--;# child domains of them.
		--;# Deletion policy: normally not modified.
		CREATE TABLE IF NOT EXISTS forbiddenSuper (
		    domain TEXT PRIMARY KEY);

		--;# When we last retrieved the domain list.
		CREATE TABLE IF NOT EXISTS domainCacheMetadata (
		    id INTEGER PRIMARY KEY,
		    retrievalDate INTEGER,
		    installDate INTEGER);
	    }

	    set cookieCount "no"
	    db eval {
		SELECT COUNT(*) AS cookieCount FROM persistentCookies
	    }
	    log info "%s with %s entries" $storeorigin $cookieCount

	    my PostponePurge

	    if {$path ne ""} {
		if {[db exists {SELECT 1 FROM domains}]} {
		    my RefreshDomains
		} else {
		    my InitDomainList
		    my PostponeRefresh
		}
	    } else {
		set data [my GetDomainListOffline metadata]
		my InstallDomainData $data $metadata
		my PostponeRefresh
	    }
	}
    }

    method PostponePurge {} {
	namespace upvar [info object namespace [self class]] \
	    purgeinterval interval
	catch {after cancel $purgeTimer}
	set purgeTimer [after $interval [namespace code {my PurgeCookies}]]
    }

    method PostponeRefresh {} {
	namespace upvar [info object namespace [self class]] \
	    refreshinterval interval
	catch {after cancel $refreshTimer}
	set refreshTimer [after $interval [namespace code {my RefreshDomains}]]
    }

    method RefreshDomains {} {
	# TODO: domain list refresh policy
	my PostponeRefresh
    }

    method HttpGet {url {timeout 0} {maxRedirects 5}} {
	for {set r 0} {$r < $maxRedirects} {incr r} {
	    set tok [::http::geturl $url -timeout $timeout]
	    try {
		if {[::http::status $tok] eq "timeout"} {
		    return -code error "connection timed out"
		} elseif {[::http::ncode $tok] == 200} {
		    return [::http::data $tok]
		} elseif {[::http::ncode $tok] >= 400} {
		    return -code error [::http::error $tok]
		} elseif {[dict exists [::http::meta $tok] Location]} {
		    set url [dict get [::http::meta $tok] Location]
		    continue
		}
		return -code error \
		    "unexpected state: [::http::code $tok]"
	    } finally {
		::http::cleanup $tok
	    }
	}
	return -code error "too many redirects"
    }
    method GetDomainListOnline {metaVar} {
	upvar 1 $metaVar meta
	namespace upvar [info object namespace [self class]] \
	    domainlist url domaincache cache
	lassign $cache when data
	if {$when > [clock seconds] - 3600} {
	    log debug "using cached value created at %s" \
		[clock format $when -format {%Y%m%dT%H%M%SZ} -gmt 1]
	    dict set meta retrievalDate $when
	    return $data
	}
	log debug "loading domain list from %s" $url
	try {
	    set when [clock seconds]
	    set data [my HttpGet $url]
	    set cache [list $when $data]
	    # TODO: Should we use the Last-Modified header instead?
	    dict set meta retrievalDate $when
	    return $data
	} on error msg {
	    log error "failed to fetch list of forbidden cookie domains from %s: %s" \
		    $url $msg
	    return {}
	}
    }
    method GetDomainListOffline {metaVar} {
	upvar 1 $metaVar meta
	namespace upvar [info object namespace [self class]] \
	    domainfile filename
	log debug "loading domain list from %s" $filename
	try {
	    set f [open $filename]
	    try {
		if {[string match *.gz $filename]} {
		    zlib push gunzip $f
		}
		fconfigure $f -encoding utf-8
		dict set meta retrievalDate [file mtime $filename]
		return [read $f]
	    } finally {
		close $f
	    }
	} on error {msg opt} {
	    log error "failed to read list of forbidden cookie domains from %s: %s" \
		    $filename $msg
	    return -options $opt $msg
	}
    }
    method InitDomainList {} {
	namespace upvar [info object namespace [self class]] \
	    offline offline
	if {!$offline} {
	    try {
		set data [my GetDomainListOnline metadata]
		if {[string length $data]} {
		    my InstallDomainData $data $metadata
		    return
		}
	    } on error {} {
		log warn "attempting to fall back to built in version"
	    }
	}
	set data [my GetDomainListOffline metadata]
	my InstallDomainData $data $metadata
    }

    method InstallDomainData {data meta} {
	set n [db total_changes]
	db transaction {
	    foreach line [split $data "\n"] {
		if {[string trim $line] eq ""} {
		    continue
		} elseif {[string match //* $line]} {
		    continue
		} elseif {[string match !* $line]} {
		    set line [string range $line 1 end]
		    set idna [string tolower [::tcl::idna encode $line]]
		    set utf [::tcl::idna decode [string tolower $line]]
		    db eval {
			INSERT OR REPLACE INTO domains (domain, forbidden)
			VALUES ($utf, 0);
		    }
		    if {$idna ne $utf} {
			db eval {
			    INSERT OR REPLACE INTO domains (domain, forbidden)
			    VALUES ($idna, 0);
			}
		    }
		} else {
		    if {[string match {\*.*} $line]} {
			set line [string range $line 2 end]
			set idna [string tolower [::tcl::idna encode $line]]
			set utf [::tcl::idna decode [string tolower $line]]
			db eval {
			    INSERT OR REPLACE INTO forbiddenSuper (domain)
			    VALUES ($utf);
			}
			if {$idna ne $utf} {
			    db eval {
				INSERT OR REPLACE INTO forbiddenSuper (domain)
				VALUES ($idna);
			    }
			}
		    } else {
			set idna [string tolower [::tcl::idna encode $line]]
			set utf [::tcl::idna decode [string tolower $line]]
		    }
		    db eval {
			INSERT OR REPLACE INTO domains (domain, forbidden)
			VALUES ($utf, 1);
		    }
		    if {$idna ne $utf} {
			db eval {
			    INSERT OR REPLACE INTO domains (domain, forbidden)
			    VALUES ($idna, 1);
			}
		    }
		}
		if {$utf ne [::tcl::idna decode [string tolower $idna]]} {
		    log warn "mismatch in IDNA handling for %s (%d, %s, %s)" \
			    $idna $line $utf [::tcl::idna decode $idna]
		}
	    }

	    dict with meta {
		set installDate [clock seconds]
		db eval {
		    INSERT OR REPLACE INTO domainCacheMetadata
			(id, retrievalDate, installDate)
		    VALUES (1, $retrievalDate, $installDate);
		}
	    }
	}
	set n [expr {[db total_changes] - $n}]
	log info "constructed domain info with %d entries" $n
    }

    # This forces the rebuild of the domain data, loading it from 
    method forceLoadDomainData {} {
	db transaction {
	    db eval {
		DELETE FROM domains;
		DELETE FROM forbiddenSuper;
		INSERT OR REPLACE INTO domainCacheMetadata
		    (id, retrievalDate, installDate)
		VALUES (1, -1, -1);
	    }
	    my InitDomainList
	}
    }

    destructor {
	catch {
	    after cancel $purgeTimer
	}
	catch {
	    after cancel $refreshTimer
	}
	catch {
	    db close
	}
	return
    }

    method GetCookiesForHostAndPath {listVar secure host path fullhost} {
	upvar 1 $listVar result
	log debug "check for cookies for %s" [locn $secure $host $path]
	set exact [expr {$host eq $fullhost}]
	db eval {
	    SELECT key, value FROM persistentCookies
	    WHERE domain = $host AND path = $path AND secure <= $secure
		AND (NOT originonly OR domain = $fullhost)
		AND originonly = $exact
	} {
	    lappend result $key $value
	    db eval {
		UPDATE persistentCookies SET lastuse = $now WHERE id = $id
	    }
	}
	set now [clock seconds]
	db eval {
	    SELECT id, key, value FROM sessionCookies
	    WHERE domain = $host AND path = $path AND secure <= $secure
		AND (NOT originonly OR domain = $fullhost)
		AND originonly = $exact
	} {
	    lappend result $key $value
	    db eval {
		UPDATE sessionCookies SET lastuse = $now WHERE id = $id
	    }
	}
    }

    method getCookies {proto host path} {
	set result {}
	set paths [splitPath $path]
	if {[regexp {[^0-9.]} $host]} {
	    set domains [splitDomain [string tolower [::tcl::idna encode $host]]]
	} else {
	    # Ugh, it's a numeric domain! Restrict it to just itself...
	    set domains [list $host]
	}
	set secure [string equal -nocase $proto "https"]
	# Open question: how to move these manipulations into the database
	# engine (if that's where they *should* be).
	#
	# Suggestion from kbk:
	#LENGTH(theColumn) <= LENGTH($queryStr) AND
	#SUBSTR(theColumn, LENGTH($queryStr) LENGTH(theColumn)+1) = $queryStr
	#
	# However, we instead do most of the work in Tcl because that lets us
	# do the splitting exactly right, and it's far easier to work with
	# strings in Tcl than in SQL.
	db transaction {
	    foreach domain $domains {
		foreach p $paths {
		    my GetCookiesForHostAndPath result $secure $domain $p $host
		}
	    }
	    return $result
	}
    }

    method BadDomain options {
	if {![dict exists $options domain]} {
	    log error "no domain present in options"
	    return 0
	}
	dict with options {}
	if {$domain ne $origin} {
	    log debug "cookie domain varies from origin (%s, %s)" \
		    $domain $origin
	    if {[string match .* $domain]} {
		set dotd $domain
	    } else {
		set dotd .$domain
	    }
	    if {![string equal -length [string length $dotd] \
		    [string reverse $dotd] [string reverse $origin]]} {
		log warn "bad cookie: domain not suffix of origin"
		return 1
	    }
	}
	if {![regexp {[^0-9.]} $domain]} {
	    if {$domain eq $origin} {
		# May set for itself
		return 0
	    }
	    log warn "bad cookie: for a numeric address"
	    return 1
	}
	db eval {
	    SELECT forbidden FROM domains WHERE domain = $domain
	} {
	    if {$forbidden} {
		log warn "bad cookie: for a forbidden address"
	    }
	    return $forbidden
	}
	if {[regexp {^[^.]+\.(.+)$} $domain -> super] && [db exists {
	    SELECT 1 FROM forbiddenSuper WHERE domain = $super
	}]} then {
	    log warn "bad cookie: for a forbidden address"
	    return 1
	}
	return 0
    }

    # A defined extension point to allow users to easily impose extra policies
    # on whether to accept cookies from a particular domain and path.
    method policyAllow {operation domain path} {
	return true
    }

    method storeCookie {options} {
	db transaction {
	    if {[my BadDomain $options]} {
		return
	    }
	    set now [clock seconds]
	    set persistent [dict exists $options expires]
	    dict with options {}
	    if {!$persistent} {
		if {![my policyAllow session $domain $path]} {
		    log warn "bad cookie: $domain prohibited by user policy"
		    return
		}
		db eval {
		    INSERT OR REPLACE INTO sessionCookies (
			secure, domain, path, key, value, originonly, creation,
			lastuse)
		    VALUES ($secure, $domain, $path, $key, $value, $hostonly,
			$now, $now);
		    DELETE FROM persistentCookies
		    WHERE domain = $domain AND path = $path AND key = $key
			AND secure <= $secure AND originonly = $hostonly
		}
		incr deletions [db changes]
		log debug "defined session cookie for %s" \
			[locn $secure $domain $path $key]
	    } elseif {$expires < $now} {
		if {![my policyAllow delete $domain $path]} {
		    log warn "bad cookie: $domain prohibited by user policy"
		    return
		}
		db eval {
		    DELETE FROM persistentCookies
		    WHERE domain = $domain AND path = $path AND key = $key
			AND secure <= $secure AND originonly = $hostonly
		}
		set del [db changes]
		db eval {
		    DELETE FROM sessionCookies
		    WHERE domain = $domain AND path = $path AND key = $key
			AND secure <= $secure AND originonly = $hostonly
		}
		incr deletions [incr del [db changes]]
		log debug "deleted %d cookies for %s" \
			$del [locn $secure $domain $path $key]
	    } else {
		if {![my policyAllow set $domain $path]} {
		    log warn "bad cookie: $domain prohibited by user policy"
		    return
		}
		db eval {
		    INSERT OR REPLACE INTO persistentCookies (
			secure, domain, path, key, value, originonly, expiry,
			creation, lastuse)
		    VALUES ($secure, $domain, $path, $key, $value, $hostonly,
			$expires, $now, $now);
		    DELETE FROM sessionCookies
		    WHERE domain = $domain AND path = $path AND key = $key
			AND secure <= $secure AND originonly = $hostonly
		}
		incr deletions [db changes]
		log debug "defined persistent cookie for %s, expires at %s" \
			[locn $secure $domain $path $key] \
			[clock format $expires]
	    }
	}
    }

    method PurgeCookies {} {
	namespace upvar [info object namespace [self class]] \
	    vacuumtrigger trigger  retainlimit retain
	my PostponePurge
	set now [clock seconds]
	log debug "purging cookies that expired before %s" [clock format $now]
	db transaction {
	    db eval {
		DELETE FROM persistentCookies WHERE expiry < $now
	    }
	    incr deletions [db changes]
	    db eval {
		DELETE FROM persistentCookies WHERE id IN (
		    SELECT id FROM persistentCookies ORDER BY lastuse ASC
		    LIMIT -1 OFFSET $retain)
	    }
	    incr deletions [db changes]
	    db eval {
		DELETE FROM sessionCookies WHERE id IN (
		    SELECT id FROM sessionCookies ORDER BY lastuse
		    LIMIT -1 OFFSET $retain)
	    }
	    incr deletions [db changes]
	}

	# Once we've deleted a fair bit, vacuum the database. Must be done
	# outside a transaction.
	if {$deletions > $trigger} {
	    set deletions 0
	    log debug "vacuuming cookie database"
	    catch {
		db eval {
		    VACUUM
		}
	    }
	}
    }

    forward Database db

    method lookup {{host ""} {key ""}} {
	set host [string tolower [::tcl::idna encode $host]]
	db transaction {
	    if {$host eq ""} {
		set result {}
		db eval {
		    SELECT DISTINCT domain FROM cookies
		    ORDER BY domain
		} {
		    lappend result [::tcl::idna decode [string tolower $domain]]
		}
		return $result
	    } elseif {$key eq ""} {
		set result {}
		db eval {
		    SELECT DISTINCT key FROM cookies
		    WHERE domain = $host
		    ORDER BY key
		} {
		    lappend result $key
		}
		return $result
	    } else {
		db eval {
		    SELECT value FROM cookies
		    WHERE domain = $host AND key = $key
		    LIMIT 1
		} {
		    return $value
		}
		return -code error "no such key for that host"
	    }
	}
    }
}

# Local variables:
# mode: tcl
# fill-column: 78
# End:

namespace eval http {
    # Allow resourcing to not clobber existing data

    variable http
    if {![info exists http]} {
	array set http {
	    -accept */*
	    -cookiejar {}
	    -pipeline 1
	    -postfresh 0
	    -proxyhost {}
	    -proxyport {}
	    -proxyfilter http::ProxyRequired
	    -repost 0
	    -urlencoding utf-8

    }

    # Let user control default keepalive for compatibility
    variable defaultKeepalive
    if {![info exists defaultKeepalive]} {
	set defaultKeepalive 0
    }

    # Regular expression used to parse cookies
    variable CookieRE {(?x)                            # EXPANDED SYNTAX
	\s*                                            # Ignore leading spaces
	([^][\u0000- ()<>@,;:\\""/?={}\u007f-\uffff]+) # Match the name
	=                                              # LITERAL: Equal sign
	([!\u0023-+\u002D-:<-\u005B\u005D-~]*)         # Match the value
	(?:
	 \s* ; \s*                                     # LITERAL: semicolon
	 ([^\u0000]+)                                  # Match the options
	)?
    }

    namespace export geturl config reset wait formatQuery quoteString
    namespace export register unregister registerError
    # - Useful, but not exported: data, size, status, code, cleanup, error,
    #   meta, ncode, mapReply, init.  Comments suggest that "init" can be used
    #   for re-initialisation, although the command is undocumented.
    # - Not exported, probably should be upper-case initial letter as part

	    # Provide a better error message in this error case
	    if {[regexp {(?i)%(?![0-9a-f][0-9a-f])..} $srvurl bad]} {
		return -code error \
		    "Illegal encoding character usage \"$bad\" in URL path"
	    }
	    return -code error "Illegal characters in URL path"
	}
	if {![regexp {^[^?#]+} $srvurl state(path)]} {
	    set state(path) /
	}
    } else {
	set srvurl /
	set state(path) /
    }
    if {$proto eq ""} {
	set proto http
    }
    set lower [string tolower $proto]
    if {![info exists urlTypes($lower)]} {
	unset $token

    Log ^B$tk begin sending request - token $token

    if {[catch {
	set state(method) $how
	puts $sock "$how $srvurl HTTP/$state(-protocol)"
	if {[dict exists $state(-headers) Host]} {
	    # Allow Host spoofing. [Bug 928154]
	    set hostHdr [dict get $state(-headers) Host]
	    regexp {^[^:]+} $hostHdr state(host)
	    puts $sock "Host: $hostHdr"
	} elseif {$port == $defport} {
	    # Don't add port in this case, to handle broken servers. [Bug
	    # #504508]
	    set state(host) $host
	    puts $sock "Host: $host"
	} else {
	    set state(host) $host
	    puts $sock "Host: $host:$port"
	}
	puts $sock "User-Agent: $http(-useragent)"
	if {($state(-protocol) >= 1.0) && $state(-keepalive)} {
	    # Send this header, because a 1.1 server is not compelled to treat
	    # this as the default.
	    puts $sock "Connection: keep-alive"

	    set start [tell $state(-querychannel)]
	    seek $state(-querychannel) 0 end
	    set state(querylength) \
		    [expr {[tell $state(-querychannel)] - $start}]
	    seek $state(-querychannel) $start
	}

	# Note that we don't do Cookie2; that's much nastier and not normally
	# observed in practice either. It also doesn't fix the multitude of
	# bugs in the basic cookie spec.
	if {$http(-cookiejar) ne ""} {
	    set cookies ""
	    set separator ""
	    foreach {key value} [{*}$http(-cookiejar) \
		    getCookies $proto $host $state(path)] {
		append cookies $separator $key = $value
		set separator "; "
	    }
	    if {$cookies ne ""} {
		puts $sock "Cookie: $cookies"
	    }
	}

	# 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

				    [string trim [string tolower $value]]
			}
			proxy-connection -
			connection {
			    set state(connection) \
				    [string trim [string tolower $value]]
			}
			set-cookie {
			    if {$http(-cookiejar) ne ""} {
				ParseCookie $token [string trim $value]
			    }
			}
		    }
		    lappend state(meta) $key [string trim $value]
		}
	    }
	} else {
	    # Now reading body
	    ##Log body - token $token

    # Not just application/foobar+xml but also image/svg+xml, so let us not
    # restrict things for now...
    if {[string match "*+xml" $minor]} {
	return false
    }
    return true
}

proc http::ParseCookie {token value} {
    variable http
    variable CookieRE
    variable $token
    upvar 0 $token state

    if {![regexp $CookieRE $value -> cookiename cookieval opts]} {
	# Bad cookie! No biscuit!
	return
    }

    # Convert the options into a list before feeding into the cookie store;
    # ugly, but quite easy.
    set realopts {hostonly 1 path / secure 0 httponly 0}
    dict set realopts origin $state(host)
    dict set realopts domain $state(host)
    foreach option [split [regsub -all {;\s+} $opts \u0000] \u0000] {
	regexp {^(.*?)(?:=(.*))?$} $option -> optname optval
	switch -exact -- [string tolower $optname] {
	    expires {
		if {[catch {
		    #Sun, 06 Nov 1994 08:49:37 GMT
		    dict set realopts expires \
			[clock scan $optval -format "%a, %d %b %Y %T %Z"]
		}] && [catch {
		    # Google does this one
		    #Mon, 01-Jan-1990 00:00:00 GMT
		    dict set realopts expires \
			[clock scan $optval -format "%a, %d-%b-%Y %T %Z"]
		}] && [catch {
		    # This is in the RFC, but it is also in the original
		    # Netscape cookie spec, now online at:
		    # <URL:http://curl.haxx.se/rfc/cookie_spec.html>
		    #Sunday, 06-Nov-94 08:49:37 GMT
		    dict set realopts expires \
			[clock scan $optval -format "%A, %d-%b-%y %T %Z"]
		}]} {catch {
		    #Sun Nov  6 08:49:37 1994
		    dict set realopts expires \
			[clock scan $optval -gmt 1 -format "%a %b %d %T %Y"]
		}}
	    }
	    max-age {
		# Normalize
		if {[string is integer -strict $optval]} {
		    dict set realopts expires [expr {[clock seconds] + $optval}]
		}
	    }
	    domain {
		# From the domain-matches definition [RFC 2109, section 2]:
		#   Host A's name domain-matches host B's if [...]
		#	A is a FQDN string and has the form NB, where N is a
		#	non-empty name string, B has the form .B', and B' is a
		#	FQDN string. (So, x.y.com domain-matches .y.com but
		#	not y.com.)
		if {$optval ne "" && ![string match *. $optval]} {
		    dict set realopts domain [string trimleft $optval "."]
		    dict set realopts hostonly [expr {
			! [string match .* $optval]
		    }]
		}
	    }
	    path {
		if {[string match /* $optval]} {
		    dict set realopts path $optval
		}
	    }
	    secure - httponly {
		dict set realopts [string tolower $optname] 1
	    }
	}
    }
    dict set realopts key $cookiename
    dict set realopts value $cookieval
    {*}$http(-cookiejar) storeCookie $realopts
}

# http::getTextLine --
#
#	Get one line with the stream in crlf mode.
#	Used if Transfer-Encoding is chunked.
#	Empty line is not distinguished from eof.  The caller must
#	be able to handle this.

# cookiejar.tcl --
#
#	Implementation of IDNA (Internationalized Domain Names for
#	Applications) encoding/decoding system, built on a punycode engine
#	developed directly from the code in RFC 3492, Appendix C (with
#	substantial modifications).
#
# This implementation includes code from that RFC, translated to Tcl; the
# other parts are:
# Copyright (c) 2014 Donal K. Fellows
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.

namespace eval ::tcl::idna {
    namespace ensemble create -command puny -map {
	encode punyencode
	decode punydecode
    }
    namespace ensemble create -command ::tcl::idna -map {
	encode IDNAencode
	decode IDNAdecode
	puny puny
	version {::apply {{} {package present tcl::idna} ::}}
    }

    proc IDNAencode hostname {
	set parts {}
	# Split term from RFC 3490, Sec 3.1
	foreach part [split $hostname "\u002E\u3002\uFF0E\uFF61"] {
	    if {[regexp {[^-A-Za-z0-9]} $part]} {
		if {[regexp {[^-A-Za-z0-9\u00a1-\uffff]} $part ch]} {
		    scan $ch %c c
		    if {$ch < "!" || $ch > "~"} {
			set ch [format "\\u%04x" $c]
		    }
		    throw [list IDNA INVALID_NAME_CHARACTER $ch] \
			"bad character \"$ch\" in DNS name"
		}
		set part xn--[punyencode $part]
		# Length restriction from RFC 5890, Sec 2.3.1
		if {[string length $part] > 63} {
		    throw [list IDNA OVERLONG_PART $part] \
			"hostname part too long"
		}
	    }
	    lappend parts $part
	}
	return [join $parts .]
    }
    proc IDNAdecode hostname {
	set parts {}
	# Split term from RFC 3490, Sec 3.1
	foreach part [split $hostname "\u002E\u3002\uFF0E\uFF61"] {
	    if {[string match -nocase "xn--*" $part]} {
		set part [punydecode [string range $part 4 end]]
	    }
	    lappend parts $part
	}
	return [join $parts .]
    }

    variable digits [split "abcdefghijklmnopqrstuvwxyz0123456789" ""]
    # Bootstring parameters for Punycode
    variable base 36
    variable tmin 1
    variable tmax 26
    variable skew 38
    variable damp 700
    variable initial_bias 72
    variable initial_n 0x80

    variable max_codepoint 0x10FFFF

    proc adapt {delta first numchars} {
	variable base
	variable tmin
	variable tmax
	variable damp
	variable skew

	set delta [expr {$delta / ($first ? $damp : 2)}]
	incr delta [expr {$delta / $numchars}]
	set k 0
	while {$delta > ($base - $tmin) * $tmax / 2} {
	    set delta [expr {$delta / ($base-$tmin)}]
	    incr k $base
	}
	return [expr {$k + ($base-$tmin+1) * $delta / ($delta+$skew)}]
    }

    # Main punycode encoding function
    proc punyencode {string {case ""}} {
	variable digits
	variable tmin
	variable tmax
	variable base
	variable initial_n
	variable initial_bias

	if {![string is boolean $case]} {
	    return -code error "\"$case\" must be boolean"
	}

	set in {}
	foreach char [set string [split $string ""]] {
	    scan $char "%c" ch
	    lappend in $ch
	}
	set output {}

	# Initialize the state:
	set n $initial_n
	set delta 0
	set bias $initial_bias

	# Handle the basic code points:
	foreach ch $string {
	    if {$ch < "\u0080"} {
		if {$case eq ""} {
		    append output $ch
		} elseif {[string is true $case]} {
		    append output [string toupper $ch]
		} elseif {[string is false $case]} {
		    append output [string tolower $ch]
		}
	    }
	}

	set b [string length $output]

	# h is the number of code points that have been handled, b is the
	# number of basic code points.

	if {$b > 0} {
	    append output "-"
	}

	# Main encoding loop:

	for {set h $b} {$h < [llength $in]} {incr delta; incr n} {
	    # All non-basic code points < n have been handled already.  Find
	    # the next larger one:

	    set m inf
	    foreach ch $in {
		if {$ch >= $n && $ch < $m} {
		    set m $ch
		}
	    }

	    # Increase delta enough to advance the decoder's <n,i> state to
	    # <m,0>, but guard against overflow:

	    if {$m-$n > (0xffffffff-$delta)/($h+1)} {
		throw {PUNYCODE OVERFLOW} "overflow in delta computation"
	    }
	    incr delta [expr {($m-$n) * ($h+1)}]
	    set n $m

	    foreach ch $in {
		if {$ch < $n && ([incr delta] & 0xffffffff) == 0} {
		    throw {PUNYCODE OVERFLOW} "overflow in delta computation"
		}

		if {$ch != $n} {
		    continue
		}

		# Represent delta as a generalized variable-length integer:

		for {set q $delta; set k $base} true {incr k $base} {
		    set t [expr {min(max($k-$bias, $tmin), $tmax)}]
		    if {$q < $t} {
			break
		    }
		    append output \
			[lindex $digits [expr {$t + ($q-$t)%($base-$t)}]]
		    set q [expr {($q-$t) / ($base-$t)}]
		}

		append output [lindex $digits $q]
		set bias [adapt $delta [expr {$h==$b}] [expr {$h+1}]]
		set delta 0
		incr h
	    }
	}

	return $output
    }

    # Main punycode decode function
    proc punydecode {string {case ""}} {
	variable tmin
	variable tmax
	variable base
	variable initial_n
	variable initial_bias
	variable max_codepoint

	if {![string is boolean $case]} {
	    return -code error "\"$case\" must be boolean"
	}

	# Initialize the state:

	set n $initial_n
	set i 0
	set first 1
	set bias $initial_bias

	# Split the string into the "real" ASCII characters and the ones to
	# feed into the main decoder. Note that we don't need to check the
	# result of [regexp] because that RE will technically match any string
	# at all.

	regexp {^(?:(.*)-)?([^-]*)$} $string -> pre post
	if {[string is true -strict $case]} {
	    set pre [string toupper $pre]
	} elseif {[string is false -strict $case]} {
	    set pre [string tolower $pre]
	}
	set output [split $pre ""]
	set out [llength $output]

	# Main decoding loop:

	for {set in 0} {$in < [string length $post]} {incr in} {
	    # Decode a generalized variable-length integer into delta, which
	    # gets added to i. The overflow checking is easier if we increase
	    # i as we go, then subtract off its starting value at the end to
	    # obtain delta.

	    for {set oldi $i; set w 1; set k $base} 1 {incr in} {
		if {[set ch [string index $post $in]] eq ""} {
		    throw {PUNYCODE BAD_INPUT LENGTH} "exceeded input data"
		}
		if {[string match -nocase {[a-z]} $ch]} {
		    scan [string toupper $ch] %c digit
		    incr digit -65
		} elseif {[string match {[0-9]} $ch]} {
		    set digit [expr {$ch + 26}]
		} else {
		    throw {PUNYCODE BAD_INPUT CHAR} \
			    "bad decode character \"$ch\""
		}
		incr i [expr {$digit * $w}]
		set t [expr {min(max($tmin, $k-$bias), $tmax)}]
		if {$digit < $t} {
		    set bias [adapt [expr {$i-$oldi}] $first [incr out]]
		    set first 0
		    break
		}
		if {[set w [expr {$w * ($base - $t)}]] > 0x7fffffff} {
		    throw {PUNYCODE OVERFLOW} \
			"excessively large integer computed in digit decode"
		}
		incr k $base
	    }

	    # i was supposed to wrap around from out+1 to 0, incrementing n
	    # each time, so we'll fix that now:

	    if {[incr n [expr {$i / $out}]] > 0x7fffffff} {
		throw {PUNYCODE OVERFLOW} \
		    "excessively large integer computed in character choice"
	    } elseif {$n > $max_codepoint} {
		if {$n >= 0x00d800 && $n < 0x00e000} {
		    # Bare surrogate?!
		    throw {PUNYCODE NON_BMP} \
			[format "unsupported character U+%06x" $n]
		}
		throw {PUNYCODE NON_UNICODE} "bad codepoint $n"
	    }
	    set i [expr {$i % $out}]

	    # Insert n at position i of the output:

	    set output [linsert $output $i [format "%c" $n]]
	    incr i
	}

	return [join $output ""]
    }
}

package provide tcl::idna 1.0

# Local variables:
# mode: tcl
# fill-column: 78
# End:

if {![package vsatisfies [package provide Tcl] 8.6-]} {return}
package ifneeded http 2.9.0 [list tclPkgSetup $dir http 2.9.0 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}]
package ifneeded cookiejar 0.1 [list source [file join $dir cookiejar.tcl]]
package ifneeded tcl::idna 1.0 [list source [file join $dir idna.tcl]]

	return
    }
}

test http-1.1 {http::config} {
    http::config -useragent UserAgent
    http::config
} [list -accept */* -cookiejar {} -pipeline 1 -postfresh 0 -proxyfilter http::ProxyRequired -proxyhost {} -proxyport {} -repost 0 -urlencoding utf-8 -useragent UserAgent -zip 1]
test http-1.2 {http::config} {
    http::config -proxyfilter
} http::ProxyRequired
test http-1.3 {http::config} {
    catch {http::config -junk}
} 1
test http-1.4 {http::config} {
    set savedconf [http::config]
    http::config -proxyhost nowhere.come -proxyport 8080 \
	-proxyfilter myFilter -useragent "Tcl Test Suite" \
	-urlencoding iso8859-1
    set x [http::config]
    http::config {*}$savedconf
    set x
} {-accept */* -cookiejar {} -pipeline 1 -postfresh 0 -proxyfilter myFilter -proxyhost nowhere.come -proxyport 8080 -repost 0 -urlencoding iso8859-1 -useragent {Tcl Test Suite} -zip 1}
test http-1.5 {http::config} -returnCodes error -body {
    http::config -proxyhost {} -junk 8080
} -result {Unknown option -junk, must be: -accept, -cookiejar, -pipeline, -postfresh, -proxyfilter, -proxyhost, -proxyport, -repost, -urlencoding, -useragent, -zip}
test http-1.6 {http::config} -setup {
    set oldenc [http::config -urlencoding]
} -body {
    set enc [list [http::config -urlencoding]]
    http::config -urlencoding iso8859-1
    lappend enc [http::config -urlencoding]
} -cleanup {

    # this would be reverting to http <=2.4 behavior w/o errors
    # (unknown chars become '?')
    http::config -urlencoding "iso8859-1"
    http::mapReply "\u2208"
} -cleanup {
    http::config -urlencoding $enc
} -result {%3F}

package require -exact tcl::idna 1.0

test http-idna-1.1 {IDNA package: basics} -returnCodes error -body {
    ::tcl::idna
} -result {wrong # args: should be "::tcl::idna subcommand ?arg ...?"}
test http-idna-1.2 {IDNA package: basics} -returnCodes error -body {
    ::tcl::idna ?
} -result {unknown or ambiguous subcommand "?": must be decode, encode, puny, or version}
test http-idna-1.3 {IDNA package: basics} -body {
    ::tcl::idna version
} -result 1.0
test http-idna-1.4 {IDNA package: basics} -returnCodes error -body {
    ::tcl::idna version what
} -result {wrong # args: should be "::tcl::idna version"}
test http-idna-1.5 {IDNA package: basics} -returnCodes error -body {
    ::tcl::idna puny
} -result {wrong # args: should be "::tcl::idna puny subcommand ?arg ...?"}
test http-idna-1.6 {IDNA package: basics} -returnCodes error -body {
    ::tcl::idna puny ?
} -result {unknown or ambiguous subcommand "?": must be decode, or encode}
test http-idna-1.7 {IDNA package: basics} -returnCodes error -body {
    ::tcl::idna puny encode
} -result {wrong # args: should be "::tcl::idna puny encode string ?case?"}
test http-idna-1.8 {IDNA package: basics} -returnCodes error -body {
    ::tcl::idna puny encode a b c
} -result {wrong # args: should be "::tcl::idna puny encode string ?case?"}
test http-idna-1.9 {IDNA package: basics} -returnCodes error -body {
    ::tcl::idna puny decode
} -result {wrong # args: should be "::tcl::idna puny decode string ?case?"}
test http-idna-1.10 {IDNA package: basics} -returnCodes error -body {
    ::tcl::idna puny decode a b c
} -result {wrong # args: should be "::tcl::idna puny decode string ?case?"}
test http-idna-1.11 {IDNA package: basics} -returnCodes error -body {
    ::tcl::idna decode
} -result {wrong # args: should be "::tcl::idna decode hostname"}
test http-idna-1.12 {IDNA package: basics} -returnCodes error -body {
    ::tcl::idna encode
} -result {wrong # args: should be "::tcl::idna encode hostname"}

test http-idna-2.1 {puny encode: functional test} {
    ::tcl::idna puny encode abc
} abc-
test http-idna-2.2 {puny encode: functional test} {
    ::tcl::idna puny encode a\u20acb\u20acc
} abc-k50ab
test http-idna-2.3 {puny encode: functional test} {
    ::tcl::idna puny encode ABC
} ABC-
test http-idna-2.4 {puny encode: functional test} {
    ::tcl::idna puny encode A\u20ACB\u20ACC
} ABC-k50ab
test http-idna-2.5 {puny encode: functional test} {
    ::tcl::idna puny encode ABC 0
} abc-
test http-idna-2.6 {puny encode: functional test} {
    ::tcl::idna puny encode A\u20ACB\u20ACC 0
} abc-k50ab
test http-idna-2.7 {puny encode: functional test} {
    ::tcl::idna puny encode ABC 1
} ABC-
test http-idna-2.8 {puny encode: functional test} {
    ::tcl::idna puny encode A\u20ACB\u20ACC 1
} ABC-k50ab
test http-idna-2.9 {puny encode: functional test} {
    ::tcl::idna puny encode abc 0
} abc-
test http-idna-2.10 {puny encode: functional test} {
    ::tcl::idna puny encode a\u20ACb\u20ACc 0
} abc-k50ab
test http-idna-2.11 {puny encode: functional test} {
    ::tcl::idna puny encode abc 1
} ABC-
test http-idna-2.12 {puny encode: functional test} {
    ::tcl::idna puny encode a\u20ACb\u20ACc 1
} ABC-k50ab
test http-idna-2.13 {puny encode: edge cases} {
    ::tcl::idna puny encode ""
} ""
test http-idna-2.14-A {puny encode: examples from RFC 3492} {
    ::tcl::idna puny encode [join [subst [string map {u+ \\u} {
	u+0644 u+064A u+0647 u+0645 u+0627 u+0628 u+062A u+0643 u+0644
	u+0645 u+0648 u+0634 u+0639 u+0631 u+0628 u+064A u+061F
    }]] ""]
} egbpdaj6bu4bxfgehfvwxn
test http-idna-2.14-B {puny encode: examples from RFC 3492} {
    ::tcl::idna puny encode [join [subst [string map {u+ \\u} {
	u+4ED6 u+4EEC u+4E3A u+4EC0 u+4E48 u+4E0D u+8BF4 u+4E2D u+6587
    }]] ""]
} ihqwcrb4cv8a8dqg056pqjye
test http-idna-2.14-C {puny encode: examples from RFC 3492} {
    ::tcl::idna puny encode [join [subst [string map {u+ \\u} {
	u+4ED6 u+5011 u+7232 u+4EC0 u+9EBD u+4E0D u+8AAA u+4E2D u+6587
    }]] ""]
} ihqwctvzc91f659drss3x8bo0yb
test http-idna-2.14-D {puny encode: examples from RFC 3492} {
    ::tcl::idna puny encode [join [subst [string map {u+ \\u} {
	u+0050 u+0072 u+006F u+010D u+0070 u+0072 u+006F u+0073 u+0074
	u+011B u+006E u+0065 u+006D u+006C u+0075 u+0076 u+00ED u+010D
	u+0065 u+0073 u+006B u+0079
    }]] ""]
} Proprostnemluvesky-uyb24dma41a
test http-idna-2.14-E {puny encode: examples from RFC 3492} {
    ::tcl::idna puny encode [join [subst [string map {u+ \\u} {
	u+05DC u+05DE u+05D4 u+05D4 u+05DD u+05E4 u+05E9 u+05D5 u+05D8
	u+05DC u+05D0 u+05DE u+05D3 u+05D1 u+05E8 u+05D9 u+05DD u+05E2
	u+05D1 u+05E8 u+05D9 u+05EA
    }]] ""]
} 4dbcagdahymbxekheh6e0a7fei0b
test http-idna-2.14-F {puny encode: examples from RFC 3492} {
    ::tcl::idna puny encode [join [subst [string map {u+ \\u} {
	u+092F u+0939 u+0932 u+094B u+0917 u+0939 u+093F u+0928 u+094D
	u+0926 u+0940 u+0915 u+094D u+092F u+094B u+0902 u+0928 u+0939
	u+0940 u+0902 u+092C u+094B u+0932 u+0938 u+0915 u+0924 u+0947
	u+0939 u+0948 u+0902
    }]] ""]
} i1baa7eci9glrd9b2ae1bj0hfcgg6iyaf8o0a1dig0cd
test http-idna-2.14-G {puny encode: examples from RFC 3492} {
    ::tcl::idna puny encode [join [subst [string map {u+ \\u} {
	u+306A u+305C u+307F u+3093 u+306A u+65E5 u+672C u+8A9E u+3092
	u+8A71 u+3057 u+3066 u+304F u+308C u+306A u+3044 u+306E u+304B
    }]] ""]
} n8jok5ay5dzabd5bym9f0cm5685rrjetr6pdxa
test http-idna-2.14-H {puny encode: examples from RFC 3492} {
    ::tcl::idna puny encode [join [subst [string map {u+ \\u} {
	u+C138 u+ACC4 u+C758 u+BAA8 u+B4E0 u+C0AC u+B78C u+B4E4 u+C774
	u+D55C u+AD6D u+C5B4 u+B97C u+C774 u+D574 u+D55C u+B2E4 u+BA74
	u+C5BC u+B9C8 u+B098 u+C88B u+C744 u+AE4C
    }]] ""]
} 989aomsvi5e83db1d2a355cv1e0vak1dwrv93d5xbh15a0dt30a5jpsd879ccm6fea98c
test http-idna-2.14-I {puny encode: examples from RFC 3492} {
    ::tcl::idna puny encode [join [subst [string map {u+ \\u} {
	u+043F u+043E u+0447 u+0435 u+043C u+0443 u+0436 u+0435 u+043E
	u+043D u+0438 u+043D u+0435 u+0433 u+043E u+0432 u+043E u+0440
	u+044F u+0442 u+043F u+043E u+0440 u+0443 u+0441 u+0441 u+043A
	u+0438
    }]] ""]
} b1abfaaepdrnnbgefbadotcwatmq2g4l
test http-idna-2.14-J {puny encode: examples from RFC 3492} {
    ::tcl::idna puny encode [join [subst [string map {u+ \\u} {
	u+0050 u+006F u+0072 u+0071 u+0075 u+00E9 u+006E u+006F u+0070
	u+0075 u+0065 u+0064 u+0065 u+006E u+0073 u+0069 u+006D u+0070
	u+006C u+0065 u+006D u+0065 u+006E u+0074 u+0065 u+0068 u+0061
	u+0062 u+006C u+0061 u+0072 u+0065 u+006E u+0045 u+0073 u+0070
	u+0061 u+00F1 u+006F u+006C
    }]] ""]
} PorqunopuedensimplementehablarenEspaol-fmd56a
test http-idna-2.14-K {puny encode: examples from RFC 3492} {
    ::tcl::idna puny encode [join [subst [string map {u+ \\u} {
	u+0054 u+1EA1 u+0069 u+0073 u+0061 u+006F u+0068 u+1ECD u+006B
	u+0068 u+00F4 u+006E u+0067 u+0074 u+0068 u+1EC3 u+0063 u+0068
	u+1EC9 u+006E u+00F3 u+0069 u+0074 u+0069 u+1EBF u+006E u+0067
	u+0056 u+0069 u+1EC7 u+0074
    }]] ""]
} TisaohkhngthchnitingVit-kjcr8268qyxafd2f1b9g
test http-idna-2.14-L {puny encode: examples from RFC 3492} {
    ::tcl::idna puny encode [join [subst [string map {u+ \\u} {
	u+0033 u+5E74 u+0042 u+7D44 u+91D1 u+516B u+5148 u+751F
    }]] ""]
} 3B-ww4c5e180e575a65lsy2b
test http-idna-2.14-M {puny encode: examples from RFC 3492} {
    ::tcl::idna puny encode [join [subst [string map {u+ \\u} {
	u+5B89 u+5BA4 u+5948 u+7F8E u+6075 u+002D u+0077 u+0069 u+0074
	u+0068 u+002D u+0053 u+0055 u+0050 u+0045 u+0052 u+002D u+004D
	u+004F u+004E u+004B u+0045 u+0059 u+0053
    }]] ""]
} -with-SUPER-MONKEYS-pc58ag80a8qai00g7n9n
test http-idna-2.14-N {puny encode: examples from RFC 3492} {
    ::tcl::idna puny encode [join [subst [string map {u+ \\u} {
	u+0048 u+0065 u+006C u+006C u+006F u+002D u+0041 u+006E u+006F
	u+0074 u+0068 u+0065 u+0072 u+002D u+0057 u+0061 u+0079 u+002D
	u+305D u+308C u+305E u+308C u+306E u+5834 u+6240
    }]] ""]
} Hello-Another-Way--fc4qua05auwb3674vfr0b
test http-idna-2.14-O {puny encode: examples from RFC 3492} {
    ::tcl::idna puny encode [join [subst [string map {u+ \\u} {
	u+3072 u+3068 u+3064 u+5C4B u+6839 u+306E u+4E0B u+0032
    }]] ""]
} 2-u9tlzr9756bt3uc0v
test http-idna-2.14-P {puny encode: examples from RFC 3492} {
    ::tcl::idna puny encode [join [subst [string map {u+ \\u} {
	u+004D u+0061 u+006A u+0069 u+3067 u+004B u+006F u+0069 u+3059
	u+308B u+0035 u+79D2 u+524D
    }]] ""]
} MajiKoi5-783gue6qz075azm5e
test http-idna-2.14-Q {puny encode: examples from RFC 3492} {
    ::tcl::idna puny encode [join [subst [string map {u+ \\u} {
	u+30D1 u+30D5 u+30A3 u+30FC u+0064 u+0065 u+30EB u+30F3 u+30D0
    }]] ""]
} de-jg4avhby1noc0d
test http-idna-2.14-R {puny encode: examples from RFC 3492} {
    ::tcl::idna puny encode [join [subst [string map {u+ \\u} {
	u+305D u+306E u+30B9 u+30D4 u+30FC u+30C9 u+3067
    }]] ""]
} d9juau41awczczp
test http-idna-2.14-S {puny encode: examples from RFC 3492} {
    ::tcl::idna puny encode {-> $1.00 <-}
} {-> $1.00 <--}

test http-idna-3.1 {puny decode: functional test} {
    ::tcl::idna puny decode abc-
} abc
test http-idna-3.2 {puny decode: functional test} {
    ::tcl::idna puny decode abc-k50ab
} a\u20acb\u20acc
test http-idna-3.3 {puny decode: functional test} {
    ::tcl::idna puny decode ABC-
} ABC
test http-idna-3.4 {puny decode: functional test} {
    ::tcl::idna puny decode ABC-k50ab
} A\u20ACB\u20ACC
test http-idna-3.5 {puny decode: functional test} {
    ::tcl::idna puny decode ABC-K50AB
} A\u20ACB\u20ACC
test http-idna-3.6 {puny decode: functional test} {
    ::tcl::idna puny decode abc-K50AB
} a\u20ACb\u20ACc
test http-idna-3.7 {puny decode: functional test} {
    ::tcl::idna puny decode ABC- 0
} abc
test http-idna-3.8 {puny decode: functional test} {
    ::tcl::idna puny decode ABC-K50AB 0
} a\u20ACb\u20ACc
test http-idna-3.9 {puny decode: functional test} {
    ::tcl::idna puny decode ABC- 1
} ABC
test http-idna-3.10 {puny decode: functional test} {
    ::tcl::idna puny decode ABC-K50AB 1
} A\u20ACB\u20ACC
test http-idna-3.11 {puny decode: functional test} {
    ::tcl::idna puny decode abc- 0
} abc
test http-idna-3.12 {puny decode: functional test} {
    ::tcl::idna puny decode abc-k50ab 0
} a\u20ACb\u20ACc
test http-idna-3.13 {puny decode: functional test} {
    ::tcl::idna puny decode abc- 1
} ABC
test http-idna-3.14 {puny decode: functional test} {
    ::tcl::idna puny decode abc-k50ab 1
} A\u20ACB\u20ACC
test http-idna-3.15 {puny decode: edge cases and errors} {
    # Is this case actually correct?
    binary encode hex [encoding convertto utf-8 [::tcl::idna puny decode abc]]
} c282c281c280
test http-idna-3.16 {puny decode: edge cases and errors} -returnCodes error -body {
    ::tcl::idna puny decode abc!
} -result {bad decode character "!"}
test http-idna-3.17 {puny decode: edge cases and errors} {
    catch {::tcl::idna puny decode abc!} -> opt
    dict get $opt -errorcode
} {PUNYCODE BAD_INPUT CHAR}
test http-idna-3.18 {puny decode: edge cases and errors} {
    ::tcl::idna puny decode ""
} {}
# A helper so we don't get lots of crap in failures
proc hexify s {lmap c [split $s ""] {format u+%04X [scan $c %c]}}
test http-idna-3.19-A {puny decode: examples from RFC 3492} {
    hexify [::tcl::idna puny decode egbpdaj6bu4bxfgehfvwxn]
} [list {*}{
    u+0644 u+064A u+0647 u+0645 u+0627 u+0628 u+062A u+0643 u+0644
    u+0645 u+0648 u+0634 u+0639 u+0631 u+0628 u+064A u+061F
}]
test http-idna-3.19-B {puny decode: examples from RFC 3492} {
    hexify [::tcl::idna puny decode ihqwcrb4cv8a8dqg056pqjye]
} {u+4ED6 u+4EEC u+4E3A u+4EC0 u+4E48 u+4E0D u+8BF4 u+4E2D u+6587}
test http-idna-3.19-C {puny decode: examples from RFC 3492} {
    hexify [::tcl::idna puny decode ihqwctvzc91f659drss3x8bo0yb]
} {u+4ED6 u+5011 u+7232 u+4EC0 u+9EBD u+4E0D u+8AAA u+4E2D u+6587}
test http-idna-3.19-D {puny decode: examples from RFC 3492} {
    hexify [::tcl::idna puny decode Proprostnemluvesky-uyb24dma41a]
} [list {*}{
    u+0050 u+0072 u+006F u+010D u+0070 u+0072 u+006F u+0073 u+0074
    u+011B u+006E u+0065 u+006D u+006C u+0075 u+0076 u+00ED u+010D
    u+0065 u+0073 u+006B u+0079
}]
test http-idna-3.19-E {puny decode: examples from RFC 3492} {
    hexify [::tcl::idna puny decode 4dbcagdahymbxekheh6e0a7fei0b]
} [list {*}{
    u+05DC u+05DE u+05D4 u+05D4 u+05DD u+05E4 u+05E9 u+05D5 u+05D8
    u+05DC u+05D0 u+05DE u+05D3 u+05D1 u+05E8 u+05D9 u+05DD u+05E2
    u+05D1 u+05E8 u+05D9 u+05EA
}]
test http-idna-3.19-F {puny decode: examples from RFC 3492} {
    hexify [::tcl::idna puny decode \
	i1baa7eci9glrd9b2ae1bj0hfcgg6iyaf8o0a1dig0cd]
} [list {*}{
    u+092F u+0939 u+0932 u+094B u+0917 u+0939 u+093F u+0928 u+094D
    u+0926 u+0940 u+0915 u+094D u+092F u+094B u+0902 u+0928 u+0939
    u+0940 u+0902 u+092C u+094B u+0932 u+0938 u+0915 u+0924 u+0947
    u+0939 u+0948 u+0902
}]
test http-idna-3.19-G {puny decode: examples from RFC 3492} {
    hexify [::tcl::idna puny decode n8jok5ay5dzabd5bym9f0cm5685rrjetr6pdxa]
} [list {*}{
    u+306A u+305C u+307F u+3093 u+306A u+65E5 u+672C u+8A9E u+3092
    u+8A71 u+3057 u+3066 u+304F u+308C u+306A u+3044 u+306E u+304B
}]
test http-idna-3.19-H {puny decode: examples from RFC 3492} {
    hexify [::tcl::idna puny decode \
	989aomsvi5e83db1d2a355cv1e0vak1dwrv93d5xbh15a0dt30a5jpsd879ccm6fea98c]
} [list {*}{
    u+C138 u+ACC4 u+C758 u+BAA8 u+B4E0 u+C0AC u+B78C u+B4E4 u+C774
    u+D55C u+AD6D u+C5B4 u+B97C u+C774 u+D574 u+D55C u+B2E4 u+BA74
    u+C5BC u+B9C8 u+B098 u+C88B u+C744 u+AE4C
}]
test http-idna-3.19-I {puny decode: examples from RFC 3492} {
    hexify [::tcl::idna puny decode b1abfaaepdrnnbgefbadotcwatmq2g4l]
} [list {*}{
    u+043F u+043E u+0447 u+0435 u+043C u+0443 u+0436 u+0435 u+043E
    u+043D u+0438 u+043D u+0435 u+0433 u+043E u+0432 u+043E u+0440
    u+044F u+0442 u+043F u+043E u+0440 u+0443 u+0441 u+0441 u+043A
    u+0438
}]
test http-idna-3.19-J {puny decode: examples from RFC 3492} {
    hexify [::tcl::idna puny decode \
	PorqunopuedensimplementehablarenEspaol-fmd56a]
} [list {*}{
    u+0050 u+006F u+0072 u+0071 u+0075 u+00E9 u+006E u+006F u+0070
    u+0075 u+0065 u+0064 u+0065 u+006E u+0073 u+0069 u+006D u+0070
    u+006C u+0065 u+006D u+0065 u+006E u+0074 u+0065 u+0068 u+0061
    u+0062 u+006C u+0061 u+0072 u+0065 u+006E u+0045 u+0073 u+0070
    u+0061 u+00F1 u+006F u+006C
}]
test http-idna-3.19-K {puny decode: examples from RFC 3492} {
    hexify [::tcl::idna puny decode \
	TisaohkhngthchnitingVit-kjcr8268qyxafd2f1b9g]
} [list {*}{
    u+0054 u+1EA1 u+0069 u+0073 u+0061 u+006F u+0068 u+1ECD u+006B
    u+0068 u+00F4 u+006E u+0067 u+0074 u+0068 u+1EC3 u+0063 u+0068
    u+1EC9 u+006E u+00F3 u+0069 u+0074 u+0069 u+1EBF u+006E u+0067
    u+0056 u+0069 u+1EC7 u+0074
}]
test http-idna-3.19-L {puny decode: examples from RFC 3492} {
    hexify [::tcl::idna puny decode 3B-ww4c5e180e575a65lsy2b]
} {u+0033 u+5E74 u+0042 u+7D44 u+91D1 u+516B u+5148 u+751F}
test http-idna-3.19-M {puny decode: examples from RFC 3492} {
    hexify [::tcl::idna puny decode -with-SUPER-MONKEYS-pc58ag80a8qai00g7n9n]
} [list {*}{
    u+5B89 u+5BA4 u+5948 u+7F8E u+6075 u+002D u+0077 u+0069 u+0074
    u+0068 u+002D u+0053 u+0055 u+0050 u+0045 u+0052 u+002D u+004D
    u+004F u+004E u+004B u+0045 u+0059 u+0053
}]
test http-idna-3.19-N {puny decode: examples from RFC 3492} {
    hexify [::tcl::idna puny decode Hello-Another-Way--fc4qua05auwb3674vfr0b]
} [list {*}{
    u+0048 u+0065 u+006C u+006C u+006F u+002D u+0041 u+006E u+006F
    u+0074 u+0068 u+0065 u+0072 u+002D u+0057 u+0061 u+0079 u+002D
    u+305D u+308C u+305E u+308C u+306E u+5834 u+6240
}]
test http-idna-3.19-O {puny decode: examples from RFC 3492} {
    hexify [::tcl::idna puny decode 2-u9tlzr9756bt3uc0v]
} {u+3072 u+3068 u+3064 u+5C4B u+6839 u+306E u+4E0B u+0032}
test http-idna-3.19-P {puny decode: examples from RFC 3492} {
    hexify [::tcl::idna puny decode MajiKoi5-783gue6qz075azm5e]
} [list {*}{
    u+004D u+0061 u+006A u+0069 u+3067 u+004B u+006F u+0069 u+3059
    u+308B u+0035 u+79D2 u+524D
}]
test http-idna-3.19-Q {puny decode: examples from RFC 3492} {
    hexify [::tcl::idna puny decode de-jg4avhby1noc0d]
} {u+30D1 u+30D5 u+30A3 u+30FC u+0064 u+0065 u+30EB u+30F3 u+30D0}
test http-idna-3.19-R {puny decode: examples from RFC 3492} {
    hexify [::tcl::idna puny decode d9juau41awczczp]
} {u+305D u+306E u+30B9 u+30D4 u+30FC u+30C9 u+3067}
test http-idna-3.19-S {puny decode: examples from RFC 3492} {
    ::tcl::idna puny decode {-> $1.00 <--}
} {-> $1.00 <-}
rename hexify ""

test http-idna-4.1 {IDNA encoding} {
    ::tcl::idna encode abc.def
} abc.def
test http-idna-4.2 {IDNA encoding} {
    ::tcl::idna encode a\u20acb\u20acc.def
} xn--abc-k50ab.def
test http-idna-4.3 {IDNA encoding} {
    ::tcl::idna encode def.a\u20acb\u20acc
} def.xn--abc-k50ab
test http-idna-4.4 {IDNA encoding} {
    ::tcl::idna encode ABC.DEF
} ABC.DEF
test http-idna-4.5 {IDNA encoding} {
    ::tcl::idna encode A\u20acB\u20acC.def
} xn--ABC-k50ab.def
test http-idna-4.6 {IDNA encoding: invalid edge case} {
    # Should this be an error?
    ::tcl::idna encode abc..def
} abc..def
test http-idna-4.7 {IDNA encoding: invalid char} -returnCodes error -body {
    ::tcl::idna encode abc.$.def
} -result {bad character "$" in DNS name}
test http-idna-4.7.1 {IDNA encoding: invalid char} {
    catch {::tcl::idna encode abc.$.def} -> opt
    dict get $opt -errorcode
} {IDNA INVALID_NAME_CHARACTER {$}}
test http-idna-4.8 {IDNA encoding: empty} {
    ::tcl::idna encode ""
} {}
set overlong www.[join [subst [string map {u+ \\u} {
    u+C138 u+ACC4 u+C758 u+BAA8 u+B4E0 u+C0AC u+B78C u+B4E4 u+C774
    u+D55C u+AD6D u+C5B4 u+B97C u+C774 u+D574 u+D55C u+B2E4 u+BA74
    u+C5BC u+B9C8 u+B098 u+C88B u+C744 u+AE4C
}]] ""].com
test http-idna-4.9 {IDNA encoding: max lengths from RFC 5890} -body {
    ::tcl::idna encode $overlong
} -returnCodes error -result "hostname part too long"
test http-idna-4.9.1 {IDNA encoding: max lengths from RFC 5890} {
    catch {::tcl::idna encode $overlong} -> opt
    dict get $opt -errorcode
} {IDNA OVERLONG_PART xn--989aomsvi5e83db1d2a355cv1e0vak1dwrv93d5xbh15a0dt30a5jpsd879ccm6fea98c}
unset overlong
test http-idna-4.10 {IDNA encoding: edge cases} {
    ::tcl::idna encode pass\u00e9.example.com
} xn--pass-epa.example.com

test http-idna-5.1 {IDNA decoding} {
    ::tcl::idna decode abc.def
} abc.def
test http-idna-5.2 {IDNA decoding} {
    # Invalid entry that's just a wrapper
    ::tcl::idna decode xn--abc-.def
} abc.def
test http-idna-5.3 {IDNA decoding} {
    # Invalid entry that's just a wrapper
    ::tcl::idna decode xn--abc-.xn--def-
} abc.def
test http-idna-5.4 {IDNA decoding} {
    # Invalid entry that's just a wrapper
    ::tcl::idna decode XN--abc-.XN--def-
} abc.def
test http-idna-5.5 {IDNA decoding: error cases} -returnCodes error -body {
    ::tcl::idna decode xn--$$$.example.com
} -result {bad decode character "$"}
test http-idna-5.5.1 {IDNA decoding: error cases} {
    catch {::tcl::idna decode xn--$$$.example.com} -> opt
    dict get $opt -errorcode
} {PUNYCODE BAD_INPUT CHAR}
test http-idna-5.6 {IDNA decoding: error cases} -returnCodes error -body {
    ::tcl::idna decode xn--a-zzzzzzzzzzzzzzzzzzzzzzzzzzzzzz.def
} -result {exceeded input data}
test http-idna-5.6.1 {IDNA decoding: error cases} {
    catch {::tcl::idna decode xn--a-zzzzzzzzzzzzzzzzzzzzzzzzzzzzzz.def} -> opt
    dict get $opt -errorcode
} {PUNYCODE BAD_INPUT LENGTH}

# cleanup
catch {unset url}
catch {unset badurl}
catch {unset port}
catch {unset data}
if {[info exists httpthread]} {

# Commands covered:  http::cookiejar
#
# This file contains a collection of tests for the cookiejar package.
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
# Copyright (c) 2014 Donal K. Fellows.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.

package require tcltest 2
namespace import -force ::tcltest::*

testConstraint cookiejar [expr {![catch {
    package require cookiejar
}]}]

test http-cookiejar-1.1 {cookie storage: packaging} cookiejar {
    package require cookiejar
} 0.1
test http-cookiejar-1.2 {cookie storage: packaging} cookiejar {
    package require cookiejar
    package require cookiejar
} 0.1

test http-cookiejar-2.1 {cookie storage: basics} -constraints cookiejar -body {
    http::cookiejar
} -returnCodes error -result {wrong # args: should be "http::cookiejar method ?arg ...?"}
test http-cookiejar-2.2 {cookie storage: basics} -constraints cookiejar -body {
    http::cookiejar ?
} -returnCodes error -result {unknown method "?": must be configure, create, destroy or new}
test http-cookiejar-2.3 {cookie storage: basics} cookiejar {
    http::cookiejar configure
} {-domainfile -domainlist -domainrefresh -loglevel -offline -purgeold -retain -vacuumtrigger}
test http-cookiejar-2.4 {cookie storage: basics} -constraints cookiejar -body {
    http::cookiejar configure a b c d e
} -returnCodes error -result {wrong # args: should be "http::cookiejar configure ?optionName? ?optionValue?"}
test http-cookiejar-2.5 {cookie storage: basics} -constraints cookiejar -body {
    http::cookiejar configure a
} -returnCodes error -result {bad option "a": must be -domainfile, -domainlist, -domainrefresh, -loglevel, -offline, -purgeold, -retain, or -vacuumtrigger}
test http-cookiejar-2.6 {cookie storage: basics} -constraints cookiejar -body {
    http::cookiejar configure -d
} -returnCodes error -result {ambiguous option "-d": must be -domainfile, -domainlist, -domainrefresh, -loglevel, -offline, -purgeold, -retain, or -vacuumtrigger}
test http-cookiejar-2.7 {cookie storage: basics} -setup {
    set old [http::cookiejar configure -loglevel]
} -constraints cookiejar -body {
    list [http::cookiejar configure -loglevel] \
	[http::cookiejar configure -loglevel debug] \
	[http::cookiejar configure -loglevel] \
	[http::cookiejar configure -loglevel error] \
	[http::cookiejar configure -loglevel]
} -cleanup {
    http::cookiejar configure -loglevel $old
} -result {info debug debug error error}
test http-cookiejar-2.8 {cookie storage: basics} -setup {
    set old [http::cookiejar configure -loglevel]
} -constraints cookiejar -body {
    list [http::cookiejar configure -loglevel] \
	[http::cookiejar configure -loglevel d] \
	[http::cookiejar configure -loglevel i] \
	[http::cookiejar configure -loglevel w] \
	[http::cookiejar configure -loglevel e]
} -cleanup {
    http::cookiejar configure -loglevel $old
} -result {info debug info warn error}
test http-cookiejar-2.9 {cookie storage: basics} -constraints cookiejar -body {
    http::cookiejar configure -off
} -match glob -result *
test http-cookiejar-2.10 {cookie storage: basics} -setup {
    set oldval [http::cookiejar configure -offline]
} -constraints cookiejar -body {
    http::cookiejar configure -offline true
} -cleanup {
    catch {http::cookiejar configure -offline $oldval}
} -result 1
test http-cookiejar-2.11 {cookie storage: basics} -setup {
    set oldval [http::cookiejar configure -offline]
} -constraints cookiejar -body {
    http::cookiejar configure -offline nonbool
} -cleanup {
    catch {http::cookiejar configure -offline $oldval}
} -returnCodes error -result {expected boolean value but got "nonbool"}
test http-cookiejar-2.12 {cookie storage: basics} -setup {
    set oldval [http::cookiejar configure -purgeold]
} -constraints cookiejar -body {
    http::cookiejar configure -purge nonint
} -cleanup {
    catch {http::cookiejar configure -purgeold $oldval}
} -returnCodes error -result {expected positive integer but got "nonint"}
test http-cookiejar-2.13 {cookie storage: basics} -setup {
    set oldval [http::cookiejar configure -domainrefresh]
} -constraints cookiejar -body {
    http::cookiejar configure -domainref nonint
} -cleanup {
    catch {http::cookiejar configure -domainrefresh $oldval}
} -returnCodes error -result {expected positive integer but got "nonint"}
test http-cookiejar-2.14 {cookie storage: basics} -setup {
    set oldval [http::cookiejar configure -domainrefresh]
} -constraints cookiejar -body {
    http::cookiejar configure -domainref -42
} -cleanup {
    catch {http::cookiejar configure -domainrefresh $oldval}
} -returnCodes error -result {expected positive integer but got "-42"}
test http-cookiejar-2.15 {cookie storage: basics} -setup {
    set oldval [http::cookiejar configure -domainrefresh]
    set result unset
    set tracer [http::cookiejar create tracer]
} -constraints cookiejar -body {
    oo::objdefine $tracer method PostponeRefresh {} {
	set ::result set
	next
    }
    http::cookiejar configure -domainref 12345
    return $result
} -cleanup {
    $tracer destroy
    catch {http::cookiejar configure -domainrefresh $oldval}
} -result set

test http-cookiejar-3.1 {cookie storage: class} cookiejar {
    info object isa object http::cookiejar
} 1
test http-cookiejar-3.2 {cookie storage: class} cookiejar {
    info object isa class http::cookiejar
} 1
test http-cookiejar-3.3 {cookie storage: class} cookiejar {
    lsort [info object methods http::cookiejar]
} {configure}
test http-cookiejar-3.4 {cookie storage: class} cookiejar {
    lsort [info object methods http::cookiejar -all]
} {configure create destroy new}
test http-cookiejar-3.5 {cookie storage: class} -setup {
    catch {rename ::cookiejar ""}
} -constraints cookiejar -body {
    namespace eval :: {http::cookiejar create cookiejar}
} -cleanup {
    catch {rename ::cookiejar ""}
} -result ::cookiejar
test http-cookiejar-3.6 {cookie storage: class} -setup {
    catch {rename ::cookiejar ""}
} -constraints cookiejar -body {
    list [http::cookiejar create ::cookiejar] [info commands ::cookiejar] \
	    [::cookiejar destroy] [info commands ::cookiejar]
} -cleanup {
    catch {rename ::cookiejar ""}
} -result {::cookiejar ::cookiejar {} {}}
test http-cookiejar-3.7 {cookie storage: class} -setup {
    catch {rename ::cookiejar ""}
} -constraints cookiejar -body {
    http::cookiejar create ::cookiejar foo bar
} -returnCodes error -cleanup {
    catch {rename ::cookiejar ""}
} -result {wrong # args: should be "http::cookiejar create ::cookiejar ?path?"}
test http-cookiejar-3.8 {cookie storage: class} -setup {
    catch {rename ::cookiejar ""}
    set f [makeFile "" cookiejar]
    file delete $f
} -constraints cookiejar -body {
    http::cookiejar create ::cookiejar $f
} -cleanup {
    catch {rename ::cookiejar ""}
    removeFile $f
} -result ::cookiejar
test http-cookiejar-3.9 {cookie storage: class} -setup {
    catch {rename ::cookiejar ""}
    set f [makeFile "bogus content for a database" cookiejar]
} -constraints cookiejar -body {
    http::cookiejar create ::cookiejar $f
} -returnCodes error -cleanup {
    catch {rename ::cookiejar ""}
    removeFile $f
} -result {file is encrypted or is not a database}
test http-cookiejar-3.10 {cookie storage: class} -setup {
    catch {rename ::cookiejar ""}
    set dir [makeDirectory cookiejar]
} -constraints cookiejar -body {
    http::cookiejar create ::cookiejar $dir
} -returnCodes error -cleanup {
    catch {rename ::cookiejar ""}
    removeDirectory $dir
} -result {unable to open database file}

test http-cookiejar-4.1 {cookie storage: instance} -setup {
    http::cookiejar create ::cookiejar
} -constraints cookiejar -body {
    cookiejar
} -returnCodes error -cleanup {
    ::cookiejar destroy
} -result {wrong # args: should be "cookiejar method ?arg ...?"}
test http-cookiejar-4.2 {cookie storage: instance} -setup {
    http::cookiejar create ::cookiejar
} -constraints cookiejar -body {
    cookiejar ?
} -returnCodes error -cleanup {
    ::cookiejar destroy
} -result {unknown method "?": must be destroy, forceLoadDomainData, getCookies, lookup or storeCookie}
test http-cookiejar-4.3 {cookie storage: instance} -setup {
    http::cookiejar create ::cookiejar
} -constraints cookiejar -body {
    lsort [info object methods cookiejar -all]
} -cleanup {
    ::cookiejar destroy
} -result {destroy forceLoadDomainData getCookies lookup storeCookie}
test http-cookiejar-4.4 {cookie storage: instance} -setup {
    http::cookiejar create ::cookiejar
} -constraints cookiejar -body {
    cookiejar getCookies
} -returnCodes error -cleanup {
    ::cookiejar destroy
} -result {wrong # args: should be "cookiejar getCookies proto host path"}
test http-cookiejar-4.5 {cookie storage} -setup {
    http::cookiejar create ::cookiejar
} -constraints cookiejar -body {
    cookiejar getCookies http www.example.com /
} -cleanup {
    ::cookiejar destroy
} -result {}
test http-cookiejar-4.6 {cookie storage: instance} -setup {
    http::cookiejar create ::cookiejar
} -constraints cookiejar -body {
    cookiejar storeCookie
} -returnCodes error -cleanup {
    ::cookiejar destroy
} -result {wrong # args: should be "cookiejar storeCookie options"}
test http-cookiejar-4.7 {cookie storage: instance} -setup {
    http::cookiejar create ::cookiejar
} -constraints cookiejar -body {
    cookiejar storeCookie {
	key foo
	value bar
	secure 0
	domain www.example.com
	origin www.example.com
	path /
	hostonly 1
    }
} -cleanup {
    ::cookiejar destroy
} -result {}
test http-cookiejar-4.8 {cookie storage: instance} -setup {
    http::cookiejar create ::cookiejar
    oo::objdefine ::cookiejar export Database
} -constraints cookiejar -body {
    cookiejar storeCookie {
	key foo
	value bar
	secure 0
	domain www.example.com
	origin www.example.com
	path /
	hostonly 1
    }
    # Poke inside implementation!
    cookiejar Database eval {SELECT count(*) FROM sessionCookies}
} -cleanup {
    ::cookiejar destroy
} -result 1
test http-cookiejar-4.9 {cookie storage: instance} -setup {
    http::cookiejar create ::cookiejar
    oo::objdefine ::cookiejar export Database
} -constraints cookiejar -body {
    cookiejar storeCookie {
	key foo
	value bar
	secure 0
	domain www.example.com
	origin www.example.com
	path /
	hostonly 1
    }
    # Poke inside implementation!
    cookiejar Database eval {SELECT count(*) FROM persistentCookies}
} -cleanup {
    ::cookiejar destroy
} -result 0
test http-cookiejar-4.10 {cookie storage: instance} -setup {
    http::cookiejar create ::cookiejar
} -constraints cookiejar -body {
    cookiejar storeCookie [dict replace {
	key foo
	value bar
	secure 0
	domain www.example.com
	origin www.example.com
	path /
	hostonly 1
    } expires [expr {[clock seconds]+5}]]
} -cleanup {
    ::cookiejar destroy
} -result {}
test http-cookiejar-4.11 {cookie storage: instance} -setup {
    http::cookiejar create ::cookiejar
    oo::objdefine ::cookiejar export Database
} -constraints cookiejar -body {
    cookiejar storeCookie [dict replace {
	key foo
	value bar
	secure 0
	domain www.example.com
	origin www.example.com
	path /
	hostonly 1
    } expires [expr {[clock seconds]+5}]]
    # Poke inside implementation!
    cookiejar Database eval {SELECT count(*) FROM sessionCookies}
} -cleanup {
    ::cookiejar destroy
} -result 0
test http-cookiejar-4.12 {cookie storage: instance} -setup {
    http::cookiejar create ::cookiejar
    oo::objdefine ::cookiejar export Database
} -constraints cookiejar -body {
    cookiejar storeCookie [dict replace {
	key foo
	value bar
	secure 0
	domain www.example.com
	origin www.example.com
	path /
	hostonly 1
    } expires [expr {[clock seconds]+5}]]
    # Poke inside implementation!
    cookiejar Database eval {SELECT count(*) FROM persistentCookies}
} -cleanup {
    ::cookiejar destroy
} -result 1
test http-cookiejar-4.13 {cookie storage: instance} -setup {
    http::cookiejar create ::cookiejar
    set result {}
} -constraints cookiejar -body {
    lappend result [cookiejar getCookies http www.example.com /]
    cookiejar storeCookie {
	key foo
	value bar
	secure 0
	domain www.example.com
	origin www.example.com
	path /
	hostonly 1
    }
    lappend result [cookiejar getCookies http www.example.com /]
} -cleanup {
    ::cookiejar destroy
} -result {{} {foo bar}}
test http-cookiejar-4.14 {cookie storage: instance} -setup {
    http::cookiejar create ::cookiejar
    set result {}
} -constraints cookiejar -body {
    lappend result [cookiejar getCookies http www.example.com /]
    cookiejar storeCookie [dict replace {
	key foo
	value bar
	secure 0
	domain www.example.com
	origin www.example.com
	path /
	hostonly 1
    } expires [expr {[clock seconds]+5}]]
    lappend result [cookiejar getCookies http www.example.com /]
} -cleanup {
    ::cookiejar destroy
} -result {{} {foo bar}}
test http-cookiejar-4.15 {cookie storage: instance} -setup {
    http::cookiejar create ::cookiejar
    set result {}
} -constraints cookiejar -body {
    lappend result [cookiejar getCookies http www.example.com /]
    cookiejar storeCookie {
	key foo
	value bar
	secure 0
	domain www.example.com
	origin www.example.com
	path /
	hostonly 1
    }
    cookiejar storeCookie [dict replace {
	key foo
	value bar
	secure 0
	domain www.example.com
	origin www.example.com
	path /
	hostonly 1
    } expires [expr {[clock seconds]+5}]]
    lappend result [cookiejar getCookies http www.example.com /]
} -cleanup {
    ::cookiejar destroy
} -result {{} {foo bar}}
test http-cookiejar-4.16 {cookie storage: instance} -setup {
    http::cookiejar create ::cookiejar
    set result {}
} -constraints cookiejar -body {
    lappend result [cookiejar getCookies http www.example.com /]
    cookiejar storeCookie {
	key foo1
	value bar
	secure 0
	domain www.example.com
	origin www.example.com
	path /
	hostonly 1
    }
    cookiejar storeCookie [dict replace {
	key foo2
	value bar
	secure 0
	domain www.example.com
	origin www.example.com
	path /
	hostonly 1
    } expires [expr {[clock seconds]+5}]]
    lappend result [lsort -stride 2 [cookiejar getCookies http www.example.com /]]
} -cleanup {
    ::cookiejar destroy
} -result {{} {foo1 bar foo2 bar}}
test http-cookiejar-4.17 {cookie storage: instance} -setup {
    http::cookiejar create ::cookiejar
} -constraints cookiejar -body {
    cookiejar lookup a b c d
} -returnCodes error -cleanup {
    ::cookiejar destroy
} -result {wrong # args: should be "cookiejar lookup ?host? ?key?"}
test http-cookiejar-4.18 {cookie storage: instance} -setup {
    http::cookiejar create ::cookiejar
    set result {}
} -constraints cookiejar -body {
    lappend result [cookiejar lookup]
    lappend result [cookiejar lookup www.example.com]
    lappend result [catch {cookiejar lookup www.example.com foo} value] $value
    cookiejar storeCookie {
	key foo
	value bar
	secure 0
	domain www.example.com
	origin www.example.com
	path /
	hostonly 1
    }
    lappend result [cookiejar lookup]
    lappend result [cookiejar lookup www.example.com]
    lappend result [cookiejar lookup www.example.com foo]
} -cleanup {
    ::cookiejar destroy
} -result {{} {} 1 {no such key for that host} www.example.com foo bar}
test http-cookiejar-4.19 {cookie storage: instance} -setup {
    http::cookiejar create ::cookiejar
    set result {}
} -constraints cookiejar -body {
    cookiejar storeCookie {
	key foo
	value bar
	secure 0
	domain www.example.com
	origin www.example.com
	path /
	hostonly 1
    }
    cookiejar storeCookie {
	key bar
	value foo
	secure 0
	domain www.example.org
	origin www.example.org
	path /
	hostonly 1
    }
    lappend result [lsort [cookiejar lookup]]
    lappend result [cookiejar lookup www.example.com]
    lappend result [cookiejar lookup www.example.com foo]
    lappend result [cookiejar lookup www.example.org]
    lappend result [cookiejar lookup www.example.org bar]
} -cleanup {
    ::cookiejar destroy
} -result {{www.example.com www.example.org} foo bar bar foo}
test http-cookiejar-4.20 {cookie storage: instance} -setup {
    http::cookiejar create ::cookiejar
    set result {}
} -constraints cookiejar -body {
    cookiejar storeCookie {
	key foo1
	value bar1
	secure 0
	domain www.example.com
	origin www.example.com
	path /
	hostonly 1
    }
    cookiejar storeCookie [dict replace {
	key foo2
	value bar2
	secure 0
	domain www.example.com
	origin www.example.com
	path /
	hostonly 1
    } expires [expr {[clock seconds]+5}]]
    lappend result [cookiejar lookup]
    lappend result [lsort [cookiejar lookup www.example.com]]
    lappend result [cookiejar lookup www.example.com foo1]
    lappend result [cookiejar lookup www.example.com foo2]
} -cleanup {
    ::cookiejar destroy
} -result {www.example.com {foo1 foo2} bar1 bar2}
test http-cookiejar-4.21 {cookie storage: instance} -setup {
    http::cookiejar create ::cookiejar
    set result {}
} -constraints cookiejar -body {
    cookiejar storeCookie {
	key foo1
	value bar1
	secure 0
	domain www.example.com
	origin www.example.com
	path /
	hostonly 1
    }
    cookiejar storeCookie {
	key foo2
	value bar2
	secure 0
	domain www.example.com
	origin www.example.com
	path /
	hostonly 1
    }
    lappend result [cookiejar lookup]
    lappend result [lsort [cookiejar lookup www.example.com]]
    lappend result [cookiejar lookup www.example.com foo1]
    lappend result [cookiejar lookup www.example.com foo2]
} -cleanup {
    ::cookiejar destroy
} -result {www.example.com {foo1 foo2} bar1 bar2}
test http-cookiejar-4.22 {cookie storage: instance} -setup {
    http::cookiejar create ::cookiejar
    set result {}
} -constraints cookiejar -body {
    cookiejar forceLoadDomainData x y z
} -returnCodes error -cleanup {
    ::cookiejar destroy
} -result {wrong # args: should be "cookiejar forceLoadDomainData"}
test http-cookiejar-4.23 {cookie storage: instance} -setup {
    http::cookiejar create ::cookiejar
    set result {}
} -constraints cookiejar -body {
    cookiejar forceLoadDomainData
} -cleanup {
    ::cookiejar destroy
} -result {}
test http-cookiejar-4.23.a {cookie storage: instance} -setup {
    set off [http::cookiejar configure -offline]
} -constraints cookiejar -body {
    http::cookiejar configure -offline 1
    [http::cookiejar create ::cookiejar] destroy
} -cleanup {
    catch {::cookiejar destroy}
    http::cookiejar configure -offline $off
} -result {}
test http-cookiejar-4.23.b {cookie storage: instance} -setup {
    set off [http::cookiejar configure -offline]
} -constraints cookiejar -body {
    http::cookiejar configure -offline 0
    [http::cookiejar create ::cookiejar] destroy
} -cleanup {
    catch {::cookiejar destroy}
    http::cookiejar configure -offline $off
} -result {}

test http-cookiejar-5.1 {cookie storage: constraints} -setup {
    http::cookiejar create ::cookiejar
    cookiejar forceLoadDomainData
} -constraints cookiejar -body {
    cookiejar storeCookie {
	key foo
	value bar
	secure 0
	domain com
	origin com
	path /
	hostonly 1
    }
    cookiejar lookup
} -cleanup {
    ::cookiejar destroy
} -result {}
test http-cookiejar-5.2 {cookie storage: constraints} -setup {
    http::cookiejar create ::cookiejar
    cookiejar forceLoadDomainData
} -constraints cookiejar -body {
    cookiejar storeCookie {
	key foo
	value bar
	secure 0
	domain foo.example.com
	origin bar.example.org
	path /
	hostonly 1
    }
    cookiejar lookup
} -cleanup {
    ::cookiejar destroy
} -result {}
test http-cookiejar-5.3 {cookie storage: constraints} -setup {
    http::cookiejar create ::cookiejar
    cookiejar forceLoadDomainData
} -constraints cookiejar -body {
    cookiejar storeCookie {
	key foo1
	value bar
	secure 0
	domain com
	origin www.example.com
	path /
	hostonly 1
    }
    cookiejar storeCookie {
	key foo2
	value bar
	secure 0
	domain example.com
	origin www.example.com
	path /
	hostonly 1
    }
    cookiejar lookup
} -cleanup {
    ::cookiejar destroy
} -result {example.com}
test http-cookiejar-5.4 {cookie storage: constraints} -setup {
    http::cookiejar create ::cookiejar
    cookiejar forceLoadDomainData
} -constraints cookiejar -body {
    cookiejar storeCookie {
	key foo
	value bar1
	secure 0
	domain www.example.com
	origin www.example.com
	path /
	hostonly 1
    }
    cookiejar storeCookie {
	key foo
	value bar2
	secure 0
	domain example.com
	origin www.example.com
	path /
	hostonly 1
    }
    lsort [cookiejar lookup]
} -cleanup {
    ::cookiejar destroy
} -result {example.com www.example.com}
test http-cookiejar-5.5 {cookie storage: constraints} -setup {
    http::cookiejar create ::cookiejar
    cookiejar forceLoadDomainData
} -constraints cookiejar -body {
    cookiejar storeCookie {
	key foo1
	value 1
	secure 0
	domain com
	origin www.example.com
	path /
	hostonly 0
    }
    cookiejar storeCookie {
	key foo2
	value 2
	secure 0
	domain com
	origin www.example.com
	path /
	hostonly 1
    }
    cookiejar storeCookie {
	key foo3
	value 3
	secure 0
	domain example.com
	origin www.example.com
	path /
	hostonly 0
    }
    cookiejar storeCookie {
	key foo4
	value 4
	secure 0
	domain example.com
	origin www.example.com
	path /
	hostonly 1
    }
    cookiejar storeCookie {
	key foo5
	value 5
	secure 0
	domain www.example.com
	origin www.example.com
	path /
	hostonly 0
    }
    cookiejar storeCookie {
	key foo6
	value 6
	secure 0
	domain www.example.com
	origin www.example.com
	path /
	hostonly 1
    }
    cookiejar storeCookie {
	key foo7
	value 7
	secure 1
	domain www.example.com
	origin www.example.com
	path /
	hostonly 0
    }
    cookiejar storeCookie {
	key foo8
	value 8
	secure 1
	domain www.example.com
	origin www.example.com
	path /
	hostonly 1
    }
    cookiejar storeCookie {
	key foo9
	value 9
	secure 0
	domain sub.www.example.com
	origin www.example.com
	path /
	hostonly 1
    }
    list [cookiejar getCookies http www.example.com /] \
	[cookiejar getCookies http www2.example.com /] \
	[cookiejar getCookies https www.example.com /] \
	[cookiejar getCookies http sub.www.example.com /]
} -cleanup {
    ::cookiejar destroy
} -result {{foo3 3 foo6 6} {foo3 3} {foo3 3 foo6 6 foo8 8} {foo3 3 foo5 5}}

test http-cookiejar-6.1 {cookie storage: expiry and lookup} -setup {
    http::cookiejar create ::cookiejar
    oo::objdefine cookiejar export PurgeCookies
    set result {}
    proc values cookies {
	global result
	lappend result [lsort [lmap {k v} $cookies {set v}]]
    }
} -constraints cookiejar -body {
    values [cookiejar getCookies http www.example.com /]
    cookiejar storeCookie {
	key foo
	value session
	secure 0
	domain www.example.com
	origin www.example.com
	path /
	hostonly 1
    }
    values [cookiejar getCookies http www.example.com /]
    cookiejar storeCookie [dict replace {
	key foo
	value cookie
	secure 0
	domain www.example.com
	origin www.example.com
	path /
	hostonly 1
    } expires [expr {[clock seconds]+1}]]
    values [cookiejar getCookies http www.example.com /]
    cookiejar storeCookie {
	key foo
	value session-global
	secure 0
	domain example.com
	origin www.example.com
	path /
	hostonly 0
    }
    values [cookiejar getCookies http www.example.com /]
    after 2500
    update
    values [cookiejar getCookies http www.example.com /]
    cookiejar PurgeCookies
    values [cookiejar getCookies http www.example.com /]
    cookiejar storeCookie {
	key foo
	value go-away
	secure 0
	domain example.com
	origin www.example.com
	path /
	hostonly 0
	expires 0
    }
    values [cookiejar getCookies http www.example.com /]
} -cleanup {
    ::cookiejar destroy
} -result {{} session cookie {cookie session-global} {cookie session-global} session-global {}}

test http-cookiejar-7.1 {cookie storage: persistence of persistent cookies} -setup {
    catch {rename ::cookiejar ""}
    set f [makeFile "" cookiejar]
    file delete $f
} -constraints cookiejar -body {
    http::cookiejar create ::cookiejar $f
    ::cookiejar destroy
    http::cookiejar create ::cookiejar $f
} -cleanup {
    catch {rename ::cookiejar ""}
    removeFile $f
} -result ::cookiejar
test http-cookiejar-7.2 {cookie storage: persistence of persistent cookies} -setup {
    catch {rename ::cookiejar ""}
    set f [makeFile "" cookiejar]
    file delete $f
    set result {}
} -constraints cookiejar -body {
    http::cookiejar create ::cookiejar $f
    cookiejar storeCookie [dict replace {
	key foo
	value cookie
	secure 0
	domain www.example.com
	origin www.example.com
	path /
	hostonly 1
    } expires [expr {[clock seconds]+1}]]
    lappend result [::cookiejar getCookies http www.example.com /]
    ::cookiejar destroy
    http::cookiejar create ::cookiejar
    lappend result [::cookiejar getCookies http www.example.com /]
    ::cookiejar destroy
    http::cookiejar create ::cookiejar $f
    lappend result [::cookiejar getCookies http www.example.com /]
} -cleanup {
    catch {rename ::cookiejar ""}
    removeFile $f
} -result {{foo cookie} {} {foo cookie}}

::tcltest::cleanupTests

# Local variables:
# mode: tcl
# End: