Index: changes ================================================================== --- changes +++ changes @@ -8794,10 +8794,59 @@ 2017-07-17 (bug)[fb2208] Repeatable tclIndex generation (wiedemann,nijtmans) --- Released 8.6.7, August 9, 2017 --- https://core.tcl-lang.org/tcl/ for details +Changes to 8.7a1 include all changes to the 8.6 line through 8.6.7, +plus the following, which focuses on the high-level feature changes +in this changeset (new minor version) rather than bug fixes: + +2016-03-17 (bug)[0b8c38] socket accept callbacks always in global ns (porter) + *** POTENTIAL INCOMPATIBILITY *** + +2016-07-01 Hack accommodations for legacy Itcl 3 disabled (porter) + +2016-07-12 Make TCL_HASH_TYPE build-time configurable (nijtmans) + +2016-07-19 (bug)[0363f0] Partial array search ID reform (porter) + +2016-07-19 (feature removed) Tcl_ObjType "array search" unregistered (porter) + *** POTENTIAL INCOMPATIBILITY for Tcl_GetObjType("array search") *** + +2016-10-04 Server socket on port 0 chooses port supporting IPv4 * IPv6 (max) + +2016-11-25 [array names -regexp] supports backrefs (goth) + +2017-01-04 (TIP 456) New routine Tcl_OpenTcpServerEx() (limeboy) + +2017-01-04 (TIP 459) New subcommand [package files] (nijtmans) + +2017-01-16 threaded allocator initialization repair (vasiljevic,nijtmans) + +2017-01-30 Add to Win shell builtins: assoc ftype move (ashok) + +2017-03-31 TCL_MEM_DEBUG facilities better support 64-bit memory (nijtmans) + +2017-04-13 \u escaped content in msg files converted to true utf-8 (nijtmans) + +2017-05-18 (TIP 458) New epoll or kqueue notifiers are default (alborboz) + +2017-05-31 Purge build support for SunOS-4.* (stu) + +2017-06-22 (TIP 463) New option [regsub ... -command ...] (fellows) + +2017-06-22 (TIP 470) Tcl_GetDefineContextObject();[oo::define [self]] (fellows) +=> TclOO 1.2.0 + +2017-06-23 (TIP 472) Support 0d as prefix of decimal numbers (iyer,griffin) + +2017-08-31 (bug)[2a9465] http state 100 continue handling broken (oehlmann) + +2017-09-02 (bug)[0e4d88] replace command, delete trace kills namespace (porter) + +--- Released 8.7a1, September 8, 2017 --- http://core.tcl.tk/tcl/ for details + 2017-08-10 [array names -regexp] supports backrefs (goth) 2017-08-10 Fix gcc build failures due to #pragma placement (cassoff,fellows) 2017-08-29 (bug)[b50fb2] exec redir append stdout and stderr to file (coulter) @@ -8893,60 +8942,181 @@ 2018-11-16 (bug)[00d04c] Repair [binary encode base64] (sebres) - Released 8.6.9, November 16, 2018 - details at http://core.tcl-lang.org/tcl/ - -Changes to 8.7a1 include all changes to the 8.6 line through 8.6.7, +2018-11-22 (bug)[7a9dc5] [file normalize ~/~foo] segfault (sebres) + +2018-12-30 (bug)[3cf3a9] variable 'timezone' deprecated in vc2017 (nijtmans) + +2019-01-09 (bug)[cc1e91] [list [list {*}[set a " "]]] regression (sebres) + +2019-02-01 (bug)[e3f481] tests var-1.2[01] (sebres) + +2019-03-01 (new) Update to Unicode 12.0 (nijtmans) + +2019-03-05 (new)[TIP 527] New command [timerate] (sebres) + +2019-03-08 (bug)[39fed4] [package require] memory validity (hume,porter) + +2019-04-23 (new) New command tcl::unsupported::corotype (fellows) + +2019-05-04 (bug) memlink when namespace deletion kills linked var (porter) + +2019-05-28 (new) README file converted to README.md in Markdown (nijtmans) + +2019-06-17 (bug)[8b9854] [info level 0] regression with ensembles (porter) + +2019-06-20 (bug)[6bdadf] crash multi-arg write-traced [lappend] (fellows,porter) + +2019-06-21 (bug)[f8a33c] crash Tcl_Exit before init (brooks,sebres) + +2019-08-27 (bug)[fa6bf3] Bytecode fails epoch recovery at numLevel=0 (sebres) + +2019-08-29 (bug)[fec0c1] C stack overflow compiling bytecode (ade,sebres) + +2019-09-12 tzdata updated to Olson's tzdata2019c (jima) + +2019-09-20 (new) registry/dde no longer need -DUNICODE (nijtmans) +=> registry 1.3.4 +=> dde 1.4.2 + +2019-10-02 (bug)[16768d] Fix [info hostname] on NetBSD (rytaro) + +2019-10-23 (new) libtommath updated to release 1.2.0 (nijtmans) + +2019-10-25 OSX: system Tcl deprecated. End default use of its packages. (walzer) + +2019-10-28 (bug)[bcd100] bad fs cache when system encoding changes (coulter) + +2019-11-15 (bug)[135804] segfault in [next] after destroy (coulter,sebres) + +- Released 8.6.10, Nov 21, 2019 - details at http://core.tcl-lang.org/tcl/ - + +Changes to 8.7a3 include all changes to the 8.6 line through 8.6.10, plus the following, which focuses on the high-level feature changes in this changeset (new minor version) rather than bug fixes: -2016-03-17 (bug)[0b8c38] socket accept callbacks always in global ns (porter) - *** POTENTIAL INCOMPATIBILITY *** - -2016-07-01 Hack accommodations for legacy Itcl 3 disabled (porter) - -2016-07-12 Make TCL_HASH_TYPE build-time configurable (nijtmans) - -2016-07-19 (bug)[0363f0] Partial array search ID reform (porter) - -2016-07-19 (feature removed) Tcl_ObjType "array search" unregistered (porter) - *** POTENTIAL INCOMPATIBILITY for Tcl_GetObjType("array search") *** - -2016-10-04 Server socket on port 0 chooses port supporting IPv4 * IPv6 (max) - -2016-11-25 [array names -regexp] supports backrefs (goth) - -2017-01-04 (TIP 456) New routine Tcl_OpenTcpServerEx() (limeboy) - -2017-01-04 (TIP 459) New subcommand [package files] (nijtmans) - -2017-01-16 threaded allocator initialization repair (vasiljevic,nijtmans) - -2017-01-30 Add to Win shell builtins: assoc ftype move (ashok) - -2017-03-31 TCL_MEM_DEBUG facilities better support 64-bit memory (nijtmans) - -2017-04-13 \u escaped content in msg files converted to true utf-8 (nijtmans) - -2017-05-18 (TIP 458) New epoll or kqueue notifiers are default (alborboz) - -2017-05-31 Purge build support for SunOS-4.* (stu) - -2017-06-22 (TIP 463) New option [regsub ... -command ...] (fellows) - -2017-06-22 (TIP 470) Tcl_GetDefineContextObject();[oo::define [self]] (fellows) -=> TclOO 1.2.0 - -2017-06-23 (TIP 472) Support 0d as prefix of decimal numbers (iyer,griffin) - -2017-08-31 (bug)[2a9465] http state 100 continue handling broken (oehlmann) - -2017-09-02 (bug)[0e4d88] replace command, delete trace kills namespace (porter) - ---- Released 8.7a1, September 8, 2017 --- http://core.tcl.tk/tcl/ for details - -2018-03-12 (TIP 490) add oo support for msgcat => msgcat 1.7.0 (oehlmann) - -2018-03-12 (TIP 499) custom locale preference list (oehlmann) +2017-11-01 (bug)[3c32a3] crash deleting class mixed into instance (coulter) + +2017-11-03 [TIP 345] eliminate the encoding 'identity' (porter) + +2017-11-04 (bug)[0d902e] [string first] on ASCII stored as Unicode (fellows) + +2017-11-17 [TIP 422] Mark all Tcl_*VA() routines deprecated. (nijtmans) + +2017-11-20 (support) Ended use of the obsolete values.h header (culler) + +2017-11-30 (bug)[8e1e31] [lsort] ordering of U+0000 (nijtmans) + +2017-12-07 [TIP 487] Terminate support for pre-XP Windows (nijtmans) + +2017-12-08 [TIP 477] Reform of nmake build (nadkarni) + +2017-12-20 (bug)[ba1419] Crash: complex ensemble delete, namespace-7.8 (coulter) + +2018-01-17 [TIP 485] Removal of many deprecated features (nijtmans) + +2018-01-27 (bug) Crash in [join $l $l], join-4.1 (porter) + +2018-02-06 [TIP 493] Cease Distribution of http 1.0 (porter) + +2018-02-06 [TIP 484] internal rep for native ints are all 64-bit (nijtmans) + +2018-02-14 [TIP 476] Scan/Printf consistency (nijtmans) + +2018-03-05 [TIP 351] [lsearch] striding + +2018-03-05 [TIPs 330,336] tighten access to Interp fields (porter) + +2018-03-12 [TIP 462] [::tcl::process] + +2018-03-12 [TIP 490] add oo support for msgcat => msgcat 1.7.0 (oehlmann) + +2018-03-12 [TIP 499] custom locale preference list (oehlmann) => msgcat 1.7.0 -- Released 8.7a3, Nov 30, 2018 --- http://core.tcl-lang.org/tcl/ for details - +2018-03-20 [TIP 503] End CONST84 support for Tcl 8.3 (porter) + +2018-03-30 Refactored [lrange] (spjuth) + +2018-04-20 [TIP 389] Unicode beyond BMP (nijtmans) + +2018-04-20 [TIP 421] [array for] + +2018-05-11 [TIP 425] Windows panic callback use of UTF-8 + +2018-05-17 [TIP 491] Phase out --disable-threads support + +2018-06-03 [TIP 500] TclOO Private Methods and Variables + +2018-07-26 (bug)[ba921a] [string cat] of bytearrays (coulter,porter) + +2018-09-02 [TIP 478] Many new features in TclOO (lester,fellows) + +2018-09-04 (bug)[540bed] [binary format w] from bignum (nijtmans) + +2018-09-12 [TIP 430] zipfs and embedded script library (woods) + +2018-09-26 [TIP 508] [array default] (bonnet,fellows) + +2018-09-27 [TIP 515] level value reform (nijtmans) + +2018-09-27 [TIP 516] More OO slot operations (fellows) + +2018-09-27 [TIP 426] [info cmdtype] (fellows) + +2018-09-28 [TIP 509] Cross platform reentrant mutex + +2018-10-08 [TIP 514] native integers are 64-bit + +2018-10-12 [TIP 502] index value reform (porter) + +2018-11-06 [TIP 406] http cookies (fellows) + +2018-11-06 [TIP 445] Tcl_ObjType utilities (migrate to Tcl 9) (porter) + +2018-11-06 [TIP 501] [string is dict] + +2018-11-06 [TIP 519] inline export/unexport option for [oo::define] + +2018-11-06 [TIP 523] [lpop] + +2018-11-06 [TIP 524] TclOO custom dialects + +2018-11-06 [TIP 506] Tcl_(Incr|Decr)RefCount macros -> functions (porter) + +2018-11-15 [TIP 512] No stub for Tcl_SetExitProc() + +2019-04-08 (bug)[45b9fa] crash in [try] (coulter) + +2019-04-14 [TIP 160] terminal and serial channel controls + +2019-04-14 [TIP 312] more types for Tcl_LinkVar + +2019-04-14 [TIP 367] [lremove] + +2019-04-14 [TIP 504] [string insert] + +2019-04-16 [TIP 342] [dict getwithdefault] + +2019-05-25 [TIP 431] [file tempdir] + +2019-05-25 [TIP 383] [coroinject], [coroprobe] + +2019-05-31 [TIP 544] Tcl_GetIntForIndex() + +2019-06-12 Replace TclOffset() with offsetof() + +2019-06-15 [TIP 461] string compare operators for [expr] + +2019-06-16 [TIP 521] floating point classification functions for [expr] + +2019-06-20 (bug)[6bdadf] crash multi-arg traced [lappend] (fellows) + +2019-06-28 [TIP 547] New encodings utf-16, ucs-2 + +2019-09-14 [TIP 414] Tcl_InitSubsystems() + +2019-09-14 [TIP 548] wchar_t conversion functions + +- Released 8.7a3, Nov 21, 2019 --- http://core.tcl-lang.org/tcl/ for details - Index: generic/tcl.h ================================================================== --- generic/tcl.h +++ generic/tcl.h @@ -49,14 +49,14 @@ */ #define TCL_MAJOR_VERSION 8 #define TCL_MINOR_VERSION 7 #define TCL_RELEASE_LEVEL TCL_ALPHA_RELEASE -#define TCL_RELEASE_SERIAL 2 +#define TCL_RELEASE_SERIAL 3 #define TCL_VERSION "8.7" -#define TCL_PATCH_LEVEL "8.7a2" +#define TCL_PATCH_LEVEL "8.7a3" #if !defined(TCL_NO_DEPRECATED) || defined(RC_INVOKED) /* *---------------------------------------------------------------------------- * The following definitions set up the proper options for Windows compilers. ADDED library/cookiejar/cookiejar.tcl Index: library/cookiejar/cookiejar.tcl ================================================================== --- /dev/null +++ library/cookiejar/cookiejar.tcl @@ -0,0 +1,745 @@ +# 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: ADDED library/cookiejar/effective_tld_names.txt.gz Index: library/cookiejar/effective_tld_names.txt.gz ================================================================== --- /dev/null +++ library/cookiejar/effective_tld_names.txt.gz cannot compute difference between binary files ADDED library/cookiejar/idna.tcl Index: library/cookiejar/idna.tcl ================================================================== --- /dev/null +++ library/cookiejar/idna.tcl @@ -0,0 +1,292 @@ +# 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 state to + # , 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: ADDED library/cookiejar/pkgIndex.tcl Index: library/cookiejar/pkgIndex.tcl ================================================================== --- /dev/null +++ library/cookiejar/pkgIndex.tcl @@ -0,0 +1,3 @@ +if {![package vsatisfies [package provide Tcl] 8.6-]} {return} +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]] DELETED library/http/cookiejar.tcl Index: library/http/cookiejar.tcl ================================================================== --- library/http/cookiejar.tcl +++ /dev/null @@ -1,745 +0,0 @@ -# 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: DELETED library/http/effective_tld_names.txt.gz Index: library/http/effective_tld_names.txt.gz ================================================================== --- library/http/effective_tld_names.txt.gz +++ /dev/null cannot compute difference between binary files DELETED library/http/idna.tcl Index: library/http/idna.tcl ================================================================== --- library/http/idna.tcl +++ /dev/null @@ -1,292 +0,0 @@ -# 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 state to - # , 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: Index: library/http/pkgIndex.tcl ================================================================== --- library/http/pkgIndex.tcl +++ library/http/pkgIndex.tcl @@ -1,4 +1,2 @@ if {![package vsatisfies [package provide Tcl] 8.6-]} {return} package ifneeded http 2.9.1 [list tclPkgSetup $dir http 2.9.1 {{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]] Index: library/init.tcl ================================================================== --- library/init.tcl +++ library/init.tcl @@ -17,11 +17,11 @@ # This test intentionally written in pre-7.5 Tcl if {[info commands package] == ""} { error "version mismatch: library\nscripts expect Tcl version 7.5b1 or later but the loaded version is\nonly [info patchlevel]" } -package require -exact Tcl 8.7a2 +package require -exact Tcl 8.7a3 # Compute the auto path to use in this interpreter. # The values on the path come from several locations: # # The environment variable TCLLIBPATH Index: unix/Makefile.in ================================================================== --- unix/Makefile.in +++ unix/Makefile.in @@ -1023,10 +1023,14 @@ @echo "Installing library files to $(SCRIPT_INSTALL_DIR)/" @for i in $(TOP_DIR)/library/*.tcl $(TOP_DIR)/library/tclIndex \ $(UNIX_DIR)/tclAppInit.c @LDAIX_SRC@ @DTRACE_SRC@ ; do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"; \ done + @echo "Installing package cookiejar 0.1 files to $(SCRIPT_INSTALL_DIR)/cookiejar0.1/" + @for i in $(TOP_DIR)/library/cookiejar/*.{tcl,txt.gz}; do \ + $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/cookiejar0.1; \ + done @echo "Installing package http 2.9.1 as a Tcl Module" @$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl \ "$(MODULE_INSTALL_DIR)"/tcl8/8.6/http-2.9.1.tm @echo "Installing package opt0.4 files to $(SCRIPT_INSTALL_DIR)/opt0.4/" @for i in $(TOP_DIR)/library/opt/*.tcl; do \ @@ -2218,11 +2222,11 @@ DISTROOT = /tmp/dist DISTNAME = tcl${VERSION}${PATCH_LEVEL} ZIPNAME = tcl${MAJOR_VERSION}${MINOR_VERSION}${PATCH_LEVEL}-src.zip DISTDIR = $(DISTROOT)/$(DISTNAME) -BUILTIN_PACKAGE_LIST = http opt msgcat reg dde tcltest platform +BUILTIN_PACKAGE_LIST = cookiejar http opt msgcat reg dde tcltest platform $(UNIX_DIR)/configure: $(UNIX_DIR)/configure.ac $(UNIX_DIR)/tcl.m4 \ $(UNIX_DIR)/aclocal.m4 cd $(UNIX_DIR); autoconf $(MAC_OSX_DIR)/configure: $(MAC_OSX_DIR)/configure.ac $(UNIX_DIR)/configure @@ -2260,10 +2264,11 @@ $(TOP_DIR)/library/tclIndex $(DISTDIR)/library @for i in $(BUILTIN_PACKAGE_LIST); do \ mkdir $(DISTDIR)/library/$$i;\ cp -p $(TOP_DIR)/library/$$i/*.tcl $(DISTDIR)/library/$$i; \ done + cp -p $(TOP_DIR)/library/cookiejar/*.txt.gz $(DISTDIR)/library/cookiejar @mkdir $(DISTDIR)/library/encoding cp -p $(TOP_DIR)/library/encoding/*.enc $(DISTDIR)/library/encoding @mkdir $(DISTDIR)/library/msgs cp -p $(TOP_DIR)/library/msgs/*.msg $(DISTDIR)/library/msgs @echo cp -r $(TOP_DIR)/library/tzdata $(DISTDIR)/library/tzdata Index: unix/configure ================================================================== --- unix/configure +++ unix/configure @@ -2380,11 +2380,11 @@ TCL_VERSION=8.7 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=7 -TCL_PATCH_LEVEL="a2" +TCL_PATCH_LEVEL="a3" VERSION=${TCL_VERSION} EXTRA_INSTALL_BINARIES=${EXTRA_INSTALL_BINARIES:-"@:"} EXTRA_BUILD_HTML=${EXTRA_BUILD_HTML:-"@:"} Index: unix/configure.ac ================================================================== --- unix/configure.ac +++ unix/configure.ac @@ -23,11 +23,11 @@ ]) TCL_VERSION=8.7 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=7 -TCL_PATCH_LEVEL="a2" +TCL_PATCH_LEVEL="a3" VERSION=${TCL_VERSION} EXTRA_INSTALL_BINARIES=${EXTRA_INSTALL_BINARIES:-"@:"} EXTRA_BUILD_HTML=${EXTRA_BUILD_HTML:-"@:"} Index: unix/tcl.spec ================================================================== --- unix/tcl.spec +++ unix/tcl.spec @@ -2,11 +2,11 @@ %{!?directory:%define directory /usr/local} Name: tcl Summary: Tcl scripting language development environment -Version: 8.7a2 +Version: 8.7a3 Release: 2 License: BSD Group: Development/Languages Source: http://prdownloads.sourceforge.net/tcl/tcl%{version}-src.tar.gz URL: http://www.tcl.tk/ Index: win/configure ================================================================== --- win/configure +++ win/configure @@ -2197,11 +2197,11 @@ SHELL=/bin/sh TCL_VERSION=8.7 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=7 -TCL_PATCH_LEVEL="a2" +TCL_PATCH_LEVEL="a3" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION TCL_DDE_VERSION=1.4 TCL_DDE_MAJOR_VERSION=1 TCL_DDE_MINOR_VERSION=4 Index: win/configure.ac ================================================================== --- win/configure.ac +++ win/configure.ac @@ -12,11 +12,11 @@ SHELL=/bin/sh TCL_VERSION=8.7 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=7 -TCL_PATCH_LEVEL="a2" +TCL_PATCH_LEVEL="a3" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION TCL_DDE_VERSION=1.4 TCL_DDE_MAJOR_VERSION=1 TCL_DDE_MINOR_VERSION=4