working towards a more consistent way of handling options in the cookiejar API

2 files changed, 43 insertions, 25 deletions

diff --git a/library/http/cookiejar.tcl b/library/http/cookiejar.tcl
index 2b1f722..f1a7f7a 100644
--- a/library/http/cookiejar.tcl
+++ b/library/http/cookiejar.tcl
@@ -85,7 +85,8 @@ namespace eval ::http {
 	    set map {debug 0 info 1 warn 2 error 3}
 	    if {[string map $map $level] >= [string map $map $loglevel]} {
 		set msg [format $msg {*}$args]
-		::http::Log "[isoNow] [string toupper $level] cookiejar($who) - ${msg}"
+		set LVL [string toupper $level]
+		::http::Log "[isoNow] $LVL cookiejar($who) - $msg"
 	    }
 	}
     }
@@ -96,6 +97,25 @@ package provide cookiejar $::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    {cookiejar_domainfile}
+	    -domainlist    {cookiejar_domainlist}
+	    -offline       {cookiejar_offline}
+	    -purgeinterval {cookiejar_purgeinterval}
+	    -vacuumtrigger {cookiejar_vacuumtrigger}
+	}
+	if {$optionName eq "\u0000\u0000"} {
+	    return [dict keys $tbl]
+	}
+	set opt [::tcl::prefix match -message "option" [dict keys $tbl] $optionName]
+	lassign [dict get $tbl $opt] varname
+	namespace upvar ::http $varname var
+	if {$optionValue ne "\u0000\u0000"} {
+	    set var $optionValue
+	}
+	return $var
+    }
     self method loglevel {{level "\u0000\u0000"}} {
 	namespace upvar ::http cookiejar_loglevel loglevel
 	if {$level ne "\u0000\u0000"} {
@@ -205,11 +225,10 @@ package provide cookiejar $::http::cookiejar_version
 	try {
 	    if {[::http::ncode $tok] == 200} {
 		return [::http::data $tok]
-	    } else {
-		log error "failed to fetch list of forbidden cookie domains from %s: %s" \
-			$url [::http::error $tok]
-		return {}
 	    }
+	    log error "failed to fetch list of forbidden cookie domains from %s: %s" \
+		    $url [::http::error $tok]
+	    return {}
 	} finally {
 	    ::http::cleanup $tok
 	}
@@ -339,7 +358,7 @@ package provide cookiejar $::http::cookiejar_version
 	db eval {
 	    SELECT key, value FROM persistentCookies
 	    WHERE domain = $host AND path = $path AND secure <= $secure
-	    AND (NOT originonly OR domain = $fullhost)
+		AND (NOT originonly OR domain = $fullhost)
 	} {
 	    lappend result $key $value
 	}
@@ -347,7 +366,7 @@ package provide cookiejar $::http::cookiejar_version
 	db eval {
 	    SELECT id, key, value FROM sessionCookies
 	    WHERE domain = $host AND path = $path AND secure <= $secure
-	    AND (NOT originonly OR domain = $fullhost)
+		AND (NOT originonly OR domain = $fullhost)
 	} {
 	    lappend result $key $value
 	    db eval {
@@ -433,51 +452,53 @@ package provide cookiejar $::http::cookiejar_version
 	return 0
     }
 
-    method storeCookie {name value options} {
-	set now [clock seconds]
+    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} {
 		db eval {
 		    INSERT OR REPLACE INTO sessionCookies (
 			secure, domain, path, key, value, originonly, creation, lastuse)
-		    VALUES ($secure, $domain, $path, $name, $value, $hostonly, $now, $now);
+		    VALUES ($secure, $domain, $path, $key, $value, $hostonly, $now, $now);
 		    DELETE FROM persistentCookies
-		    WHERE domain = $domain AND path = $path AND key = $name AND secure <= $secure
+		    WHERE domain = $domain AND path = $path AND key = $key
+			AND secure <= $secure
 		}
 		incr deletions [db changes]
 		log debug "defined session cookie for %s" \
-			[locn $secure $domain $path $name]
+			[locn $secure $domain $path $key]
 	    } elseif {$expires < $now} {
 		db eval {
 		    DELETE FROM persistentCookies
-		    WHERE domain = $domain AND path = $path AND key = $name
+		    WHERE domain = $domain AND path = $path AND key = $key
 			AND secure <= $secure;
 		}
 		set del [db changes]
 		db eval {
 		    DELETE FROM sessionCookies
-		    WHERE domain = $domain AND path = $path AND key = $name
+		    WHERE domain = $domain AND path = $path AND key = $key
 			AND secure <= $secure;
 		}
 		incr deletions [incr del [db changes]]
 		log debug "deleted %d cookies for %s" \
-			$del [locn $secure $domain $path $name]
+			$del [locn $secure $domain $path $key]
 	    } else {
 		db eval {
 		    INSERT OR REPLACE INTO persistentCookies (
 			secure, domain, path, key, value, originonly, expiry, creation)
-		    VALUES ($secure, $domain, $path, $name, $value, $hostonly, $expires, $now);
+		    VALUES ($secure, $domain, $path, $key, $value, $hostonly, $expires, $now);
 		    DELETE FROM sessionCookies
-		    WHERE domain = $domain AND path = $path AND key = $name AND secure <= $secure
+		    WHERE domain = $domain AND path = $path AND key = $key
+			AND secure <= $secure
 		}
 		incr deletions [db changes]
 		log debug "defined persistent cookie for %s, expires at %s" \
-			[locn $secure $domain $path $name] \
+			[locn $secure $domain $path $key] \
 			[clock format $expires]
 	    }
 	}
diff --git a/library/http/http.tcl b/library/http/http.tcl
index 81a008a..8720be1 100644
--- a/library/http/http.tcl
+++ b/library/http/http.tcl
@@ -1207,7 +1207,7 @@ proc http::ParseCookie {token value} {
 
     # Convert the options into a list before feeding into the cookie store;
     # ugly, but quite easy.
-    set realopts {persistent 0 hostonly 1 path / secure 0 httponly 0}
+    set realopts {hostonly 1 path / secure 0 httponly 0}
     dict set realopts origin $state(host)
     dict set realopts domain $state(host)
     foreach opt [split [regsub -all {;\s+} $opts \u0000] \u0000] {
@@ -1218,13 +1218,11 @@ proc http::ParseCookie {token value} {
 		    #Sun, 06 Nov 1994 08:49:37 GMT
 		    dict set realopts expires \
 			[clock scan $opt -format "%a, %d %b %Y %T %Z"]
-		    dict set realopts persistent 1
 		}] && [catch {
 		    # Google does this one
 		    #Mon, 01-Jan-1990 00:00:00 GMT
 		    dict set realopts expires \
 			[clock scan $opt -format "%a, %d-%b-%Y %T %Z"]
-		    dict set realopts persistent 1
 		}] && [catch {
 		    # This is in the RFC, but it is also in the original
 		    # Netscape cookie spec, now online at:
@@ -1232,12 +1230,10 @@ proc http::ParseCookie {token value} {
 		    #Sunday, 06-Nov-94 08:49:37 GMT
 		    dict set realopts expires \
 			[clock scan $opt -format "%A, %d-%b-%y %T %Z"]
-		    dict set realopts persistent 1
 		}]} {catch {
 		    #Sun Nov  6 08:49:37 1994
 		    dict set realopts expires \
 			[clock scan $opt -gmt 1 -format "%a %b %d %T %Y"]
-		    dict set realopts persistent 1
 		}}
 	    }
 	    Max-Age=* {
@@ -1245,7 +1241,6 @@ proc http::ParseCookie {token value} {
 		set opt [string range $opt 8 end]
 		if {[string is integer -strict $opt]} {
 		    dict set realopts expires [expr {[clock seconds] + $opt}]
-		    dict set realopts persistent 1
 		}
 	    }
 	    Domain=* {
@@ -1267,7 +1262,9 @@ proc http::ParseCookie {token value} {
 	    }
 	}
     }
-    {*}$http(-cookiejar) storeCookie $cookiename $cookieval $realopts
+    dict set realopts key $cookiename
+    dict set realopts value $cookieval
+    {*}$http(-cookiejar) storeCookie $realopts
 }
 
 # http::getTextLine --