======
    # Cookies - a package to provide parsing and formatting of HTTP cookies
    # according to rfc2109 (with a nod to Netscape)
    #
    # TODO: effective filtering of cookies for a given URL
    #
    # URL: http://wiki.tcl.tk/Cookies.tcl
    #
    # Modification:
    # Wed, 31st Jan, 2007	Initial Release	Colin McCormack (colin at chinix dot com)
    ####
    
    package provide Cookies 1.0
    
    namespace eval Cookies {
        # filter all expired cookies from a cookie dict
        proc expire {cookies {now ""}} {
    	# get a time value as a base for expiry calculations
    	if {$now eq ""} {
    	    set now [clock seconds]
    	}
    	
    	# expire old cookies
    	dict for {name cdict} $cookies {
    	    # ensure the cookie expires when it's supposed to
    	    set name [dict get $cdict -name]
    	    if {[dict exists $cdict -when] && ([dict exists $cdict -when] < $now)} {
    		dict unset cookies $name	;# delete expired cookie
    		continue
    	    }
    	}
    	return $cookies
        }
    
        # return an http date
        proc DateInSeconds {date} {
    	if {[string is integer -strict $date]} {
    	    return $date
    	} elseif {[catch {clock scan $date \
    			-format {%a, %d %b %Y %T GMT} \
    			-gmt true} result eo]} {
    	    error "DateInSeconds '$date', ($result)"
    	} else {
    	    return $result
    	}
        }
    
        # filter all expired cookies from a cookie dict stored in a record
        proc expire_record {rec} {
    	if {[dict exists $rec -cookies]} {
    	    # get a time value as a base for expiry calculations
    	    if {[dict exists $rec date]} {
    		set now [DateInSeconds [dict get $rec date]]
    	    } else {
    		set now [clock seconds]
    	    }
    	    dict set rec -cookies [expire [dict get $rec -cookies] $now]
    	}
    	return $rec
        }
    
        # filter a cookie dict according to the url dict given
        # TODO: filter by domain and path
        proc filter {cookie_dict args} {
    	if {[llength $args] eq 1} {
    	    set url_dict [lindex $args 0]
    	} else {
    	    set url_dict $args
    	}
    
    	# decide which cookies are in and out according to rfc2109
    
    	return $cookie_dict
        }
    
        # format a cookie dict into a list of 'cookie:' values
        # ready to be sent by Http/1.1 client
        proc format4client {cookie_dict {secure 0}} {
    	Debug.cookies {format4client save $cookie_dict}
    
    	set cookies {}	;# list of cookies in rfc2109 format
    	dict for {name cdict} $cookie_dict {
    	    if {[string match "-*" $name]} {
    		continue
    	    }
    	    # secure cookies should not be sent over insecure connection
    	    if {[dict exists $cdict -secure] && !$secure} {
    		continue
    	    }
    
    	    # cdict is a cookie record, comprising:
    	    # rfc-specified attributes:
    	    # -path, -comment, -domain, -max-age, -expires -secure, etc.
    	    #
    	    # and internal attributes:
    	    # -name (the original name of the cookie)
    	    # -when (the absolute seconds when the cookie expires)
    
    	    # first send the $Version
    	    if {![dict exists $cdict -version]} {
    		dict set cdict -version 0
    	    }
    	    set cookie "\$Version=[dict get $cdict -version]"
    
    	    # then the named value
    	    set name [dict get $cdict -name]
    	    set val [dict get $cdict -value]
    	    if {[string is alnum -strict $val]} {
    		lappend cookie "$name=[dict get $cdict -value]"
    	    } else {
    		lappend cookie "$name=\"[dict get $cdict -value]\""
    	    }
    
    	    # then other cookie fields with values
    	    foreach k {domain path} {
    		if {[dict exists $cdict -$k]} {
    		    set v [dict get $cdict -$k]
    		    set k [string totitle $k]
    		    if {![string is alnum -strict $v]} {
    			lappend cookie "\$$k=\"$v\""
    		    } else {
    			lappend cookie "\$$k=$v"
    		    }
    		}
    	    }
    
    	    lappend cookies [join $cookie ";"]
    	}
    
    	return $cookies
        }
    
        # decode a cookie header received from a server into a dict
        proc parse4client {cookies {now ""}} {
    	# get a time value as a base for expiry calculations
    	if {$now eq ""} {
    	    set now [clock seconds]
    	}
    
    	set cdict [dict create]
    
    	Debug.cookies {PREEXPIRES: $cookies} 9
    
    	# hide and strip quoted strings
    	catch {unset quoted}
    	set re \[\"\](\[^\"\]*)\[\"\]	;# quoted string
    	set cnt 0
    	while {[regexp $re $cookies -> quoted(\x84$cnt\x85)]} {
    	    regsub $re $cookies "\x84$cnt\x85" cookies
    	    incr cnt
    	}
    
    	# clean up the absolutely awful "expires" field.
    	# we look for these naked time-values (which contain commas) and remove them
    	# prior to splitting on ',', then resubstitute them - awful hack - blame netscape.
    	catch {unset expires}
    	set re {((Mon|Tue|Wed|Thu|Fri|Sat|Sun)[^,]*, +[0-9]+-(Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec)-[0-9]+ [0-9]+:[0-9]+:[0-9]+ GMT)}
    	set cnt 0
    	while {[regexp $re $cookies expires(\x81$cnt\x82)]} {
    	    regsub $re $cookies "\x81$cnt\x82" cookies
    	    incr cnt
    	}
    
    	# distinguish the real delimiters in the set-cookie field
    	# split on delimeter, substitute back hidden values
    	set cookies [string map {, \x83 ; \x86} $cookies]
    	set cookies [string map [array get expires] [split $cookies "\x83"]]
    	Debug.cookies {PROCESSING: [array get expires] - $cookies} 9
    
    	# construct an attribute dict for each cookie
    	set attrs [dict create]
    	foreach cookie $cookies {
    	    set cookie [string map [array get quoted] [split $cookie "\x86"]]
    	    Debug.cookies {Client Parsing: $cookie}
    	    set cval [string trim [join [lassign [split [lindex $cookie 0] =] name] =]]
    
    	    # process each cookie's attributes
    	    foreach term [lrange $cookie 1 end] {
    		set val [string trim [join [lassign [split $term =] attr] =]]
    		set attr [string trim $attr]
    		Debug.cookies {ATTR '$attr' $val}
    		dict set attrs -$attr [string trim $val \"]
    	    }
    
    	    # check cookie values, ensure -domain is in .form, etc.
    	    # TODO
    
    	    # store attribute dict into cookie dict by unique name
    	    dict set attrs -value $cval
    	    dict set attrs -name $name
    	    set cname [unique $attrs]	;# get full name of cookie
    	    dict set cdict $cname $attrs
    
    	    # set expiry time
    	    if {[dict exists $cdict $cname -expires]} {
    		dict set cdict $cname -when [clock scan [dict get $cdict $cname -expires]]
    	    } elseif {[dict exists $cdict $cname -max-age]} {
    		dict set cdict $cname -when [expr {$now + [dict get $cdict $cname -expires]}]
    	    }
    	}
    
    	return $cdict
        }
    
        # load cookies from a server's response into a cookie dict
        proc load_server_cookies {rsp} {
    	Debug.cookies {load $rsp}
    
    	if {[dict exists $rsp set-cookie]} {
    	    # get a time value as a base for expiry calculations
    	    if {[dict exists $rsp date]} {
    		set now [DateInSeconds [dict get $rsp date]]
    	    } else {
    		set now [clock seconds]
    	    }
    	    Debug.cookies {Cookies to parse: [dict get $rsp set-cookie]}
    	    dict set rsp -cookies [parse4client [dict get $rsp set-cookie] $now]
    	} else {
    	    Debug.cookies {load NO cookie}
    	}
    
    	return $rsp
        }
    
        # Save the -cookie sub-dict into fields ready to be sent by HTTP/1.1 server
        proc format4server {cookie_dict {secure 0}} {
    	set cookies {}	;# collection of cookies in cookie1 format
    	dict for {name cdict} $cookie_dict {
    	    if {[string match "-*" $name]} {
    		continue
    	    }
    	    if {[dict exists $cdict -secure] && !$secure} {
    		continue	;# secure cookies shouldn't be sent over insecure connection
    
    	    }
    
    	    # cdict is a cookie record, comprising:
    	    # rfc-specified attributes:
    	    # -path, -comment, -domain, -max-age, -expires -secure, etc.
    	    #
    	    # and internal attributes:
    	    # -name (the original name of the cookie)
    	    # -when (the absolute seconds when the cookie expires)
    	    set name [dict get $cdict -name]
    	    set val [dict get $cdict -value]
    	    if {[string is alnum -strict $val]} {
    		set cookie "$name=[dict get $cdict -value]"
    	    } else {
    		set cookie "$name=\"[dict get $cdict -value]\""
    	    }
    
    	    # cookie fields with values
    	    foreach k {comment domain max-age path expires} {
    		if {[dict exists $cdict -$k]} {
    		    set v [dict get $cdict -$k]
    		    if {![string is alnum -strict $v]} {
    			lappend cookie "$k=\"$v\""
    		    } else {
    			lappend cookie "$k=$v"
    		    }
    		}
    	    }
    	    
    	    # assemble cookie
    	    if {$cookie != {}} {
    		lappend cookie "version=1"
    	    }
    	    lappend cookies [join $cookie ";"]
    	}
    
    	Debug.cookies {format4server value: ($cookies)}
    	return $cookies
    	#set rsp [Http Vary $rsp set-cookie]	;# cookies are significant to caching
        }
    
        # decode a cookie header received from a client.
        proc parse4server {cookies} {
    	set cdict [dict create]	;# empty cookie dict
    
    	# hide and strip quoted strings
    	catch {unset quoted}
    	set re \[\"\](\[^\"\]*)\[\"\]	;# quoted string
    	set cnt 0
    	while {[regexp $re $cookies -> quoted(\x84$cnt\x85)]} {
    	    regsub $re $cookies "\x84$cnt\x85" cookies
    	    incr cnt
    	}
    
    	set cookies [string map {, ;} $cookies]	;# comma and ; are identical
    	set cookies [split $cookies ";"]
    
    	# process each cookie from client
    	set cname ""
    	set attrs [dict create]
    	set version 0
    	foreach cookie $cookies {
    	    set cookie [string trim [string map [array get quoted] $cookie]]
    
    	    Debug.cookies {TRYING '$cookie'} 10
    	    set val [string trim [join [lassign [split $cookie =] name] =]]
    	    set name [string trim [string tolower $name]]
    
    	    if {[string match {$*} $name]} {
    		# it's a reserved name which applies to the previous cookie
    		set name [string range $name 1 end]
    		dict set attrs -$name $val
    		if {$name eq "version"} {
    		    set version $val
    		    dict unset attrs -version
    		}
    	    } else {
    		if {[dict size $attrs] != 0} {
    		    # we have the full dict for previous cookie,
    		    # save it uniquely in cdict
    		    dict set attrs -version $version
    		    set cname [unique $attrs]
    		    dict set cdict $cname $attrs
    		    set attrs [dict create]
    		}
    
    		# it's a value name, but we can't store it
    		# until we have -path, -domain
    		dict set attrs -value $val
    		dict set attrs -name $name
    	    }
    	}
    
    	# store final cookie's values
    	if {[dict size $attrs] != 0} {
    	    dict set attrs -version $version
    	    set cname [unique $attrs]
    	    dict set cdict $cname $attrs
    	}
    
    	return $cdict
        }
    
        # load cookies from a client's request
        proc load_client_cookies {req} {
    	if {[dict exists $rsp cookie]} {
    	    dict set req -cookies [parse4server [dict get $req cookie]]
    	}
    	return $req
        }
    
        # construct a unique name for cookie storage
        # cookies are distinguished by -name, -domain and -path qualifiers
        proc unique {cookie} {
    	Debug.cookies {unique: $cookie} 10
    	if {![dict exists $cookie -domain]} {
    	    dict set cookie -domain ""
    	}
    	if {![dict exists $cookie -path]} {
    	    dict set cookie -path ""
    	}
    	return [list [dict get $cookie -domain] [dict get $cookie -path] [dict get $cookie -name]]
        }
    
        # return a list of unique cookie names within cookies dict
        # which match the template given in $args
        proc match {cookies args} {
    	if {[llength $args] eq 1} {
    	    set args [lindex $args 0]
    	}
    
    	foreach v {name path domain} {
    	    if {[dict exists $args -$v]} {
    		set $v [dict get $args -$v]
    	    } else {
    		set $v "*"
    	    }
    	}
    
    	set matches [dict keys $cookies [list $domain $path $name]]
    	Debug.cookies {match ($cookies) $args -> $matches}
    
    	return $matches
        }
    
        # clear all cookies in cookie dict which match the template in args
        # note: the cookies are modified to a state intended to cause a client
        # to drop the cookie from their local cookie jar. YMMV.
        proc clear {cookies args} {
    	Debug.cookies {Cookie clear ($cookies) $args}
    	if {[llength $args] eq 1} {
    	    set args [lindex $args 0]
    	}
    
    	dict for n [match $cookies $args] {
    	    Debug.cookies {Cookie clear $n}
    	    dict set cookies $n -value ""
    	    dict set cookies $n -max-age 0
    	    dict set cookies $n -changed 1
    	}
    	return $cookies
        }
    
        # add a cookie to the cookie dict.
        # Cookie must be unique (by -name, -domain, -path)
        proc add {cookies args} {
    	Debug.cookies {Cookie add ($cookies) $args}
    	if {[llength $args] eq 1} {
    	    set args [lindex $args 0]
    	}
    
    	set cn [unique $args]
    	if {[dict exists $cookies $cn]} {
    	    error "Duplicate cookie $args"
    	}
    	if {0 && ![string is alnum -strict [dict get $args -name]]} {
    	    # not strictly true - can include _
    	    error "name must be alphanumeric, '[dict get $args -name]'"
    	}
    	foreach {attr val} $args {
    	    dict set cookies $cn [string tolower $attr] $val
    	}
    	dict set cookies $cn -changed 1
    
    	return $cookies
        }
    
        # remove cookies from the cookie dict.
        proc remove {cookies args} {
    	Debug.cookies {Cookie remove ($cookies) $args}
    	if {[llength $args] eq 1} {
    	    set args [lindex $args 0]
    	}
    
    	foreach n [match $cookies $args] {
    	    dict unset cookies $n
    	}
    	return $cookies
        }
    
        # modify matching cookies in the cookie dict.
        proc modify {cookies args} {
    	Debug.cookies {Cookie modify $cookies $args}
    	if {[llength $args] eq 1} {
    	    set args [lindex $args 0]
    	}
    
    	# construct a modifier dict, as distinct from a selector dict
    	# because modify can't change the name elements of a cookie
    	set mods $args
    	catch {dict unset mods -name}
    	catch {dict unset mods -path}
    	catch {dict unset mods -domain}
    
    	foreach cookie [match $cookies $args] {
    	    foreach {attr val} $mods {
    		dict set cookies $cookie $attr $val
    	    }
    	    dict cookies $cookie -changed 1
    	}
    	return $cookies
        }
    
        # fetch a single matching cookie's value from the cookie dict.
        proc fetch {cookies args} {
    	Debug.cookies {Cookie fetch $cookies $args}
    	if {[llength $args] eq 1} {
    	    set args [lindex $args 0]
    	}
    
    	set matches [match $cookies $args]
    	if {[llength $matches] != 1} {
    	    error "Multiple matches: $matches"
    	}
    
    	return [dict get $cookies [lindex $matches 0]]
        }
    
        # fetch all matching cookie's values from the cookie dict.
        proc fetchAll {cookies args} {
    	Debug.cookies {Cookie fetch $cookies $args}
    	if {[llength $args] eq 1} {
    	    set args [lindex $args 0]
    	}
    
    	set matches 
    	set result {}
    	foreach n [match $cookies $args] {
    	    lappend result $n [dict get $cookies $n]
    	}
    	return $result
        }
    
        namespace export -clear *
        namespace ensemble create -subcommands {}
    }
    
    if {[info exists argv0] && ($argv0 eq [info script])} {
        lappend auto_path [file dirname [info script]]
        if {[catch {package require Debug}]} {
    	proc Debug.cookies {args} {
    	}
        } else {
    	Debug off cookies 10
        }
    
        # parsing cookies from a client
        foreach sc {
    	{$Version="1"; Customer="WILE_E_COYOTE"; $Path="/acme"}
    	{$Version="1"; Customer="WILE_E_COYOTE"; $Path="/acme"; Part_Number="Rocket_Launcher_0001"; $Path="/acme"}
    	{$Version="1"; Customer="WILE_E_COYOTE"; $Path="/acme"; Part_Number="Rocket_Launcher_0001"; $Path="/acme"; Shipping="FedEx"; $Path="/acme"}
    	{$Version="1"; Part_Number="Riding_Rocket_0023"; $Path="/acme/ammo"; Part_Number="Rocket_Launcher_0001"; $Path="/acme"}} {
    	set cd [Cookies parse4server $sc]
    	puts "$sc -> ($cd) -> [Cookies format4server $cd] + [Cookies format4client $cd]"
        }
    
        # parsing cookies from a server
        foreach sc {
    	{Customer="WILE_E_COYOTE"; Version="1"; Path="/acme"}
    	{Part_Number="Rocket_Launcher_0001"; Version="1"; Path="/acme"}
    	{Shipping="FedEx"; Version="1"; Path="/acme"}
    	{Part_Number="Rocket_Launcher_0001"; Version="1"; Path="/acme"}
    	{Part_Number="Riding_Rocket_0023"; Version="1"; Path="/acme/ammo"}
        } {
    	set cd [Cookies parse4client $sc]
    	puts "$sc -> ($cd) -> [Cookies format4server $cd] + [Cookies format4client $cd]"
        }
    
        # direct access tests - there should be more of these :)
        set x [dict create]
        foreach sc {
    	{Customer WILE_E_COYOTE -path /acme}
    	{Part_Number Rocket_Launcher_0001 -path /acme}
    	{Shipping FedEx -path /acme}
        } {
    	set attrs [lassign $sc name val]
    	set x [Cookies add $x -name $name -value $val {*}$attrs]
        }
    }
    
    # Here's the relevant syntax from rfc2109
    
    # Set-Cookie: has the following syntax
    #
    # av-pairs = av-pair *(";" av-pair)
    # av-pair = attr ["=" value]              ; optional value
    # attr = token
    # value = token | quoted-string
    #
    #   set-cookie      =       "Set-Cookie:" cookies
    #   cookies         =       1#cookie
    #   cookie          =       NAME "=" VALUE *(";" cookie-av)
    #   NAME            =       attr
    #   VALUE           =       value
    #   cookie-av       =       "Comment" "=" value
    #                   |       "Domain" "=" value
    #                   |       "Max-Age" "=" value
    #                   |       "Path" "=" value
    #                   |       "Secure"
    #                   |       "Version" "=" 1*DIGIT
    
    # Cookie: has the following syntax:
    #
    # cookie          =  "Cookie:" cookie-version 1*((";" | ",") cookie-value)
    # cookie-value    =  NAME "=" VALUE [";" path] [";" domain] [";" port]
    # cookie-version  =  "$Version" "=" value
    # NAME            =  attr
    # VALUE           =  value
    # path            =  "$Path" "=" value
    # domain          =  "$Domain" "=" value
======