From 0d4a963517b406df24acb3713a130366b1ce52a1 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 7 Jul 2012 12:34:39 +0000 Subject: Starting work on support code for cookies. This adds a configurable interface for plugging in a cookie manager (not enabled by default). --- library/http/http.tcl | 93 +++++++++++++++++++++++++++++++++++++++++++++++++++ tests/http.test | 6 ++-- 2 files changed, 96 insertions(+), 3 deletions(-) diff --git a/library/http/http.tcl b/library/http/http.tcl index b5ce82b..7b80524 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -24,6 +24,7 @@ namespace eval http { -proxyport {} -proxyfilter http::ProxyRequired -urlencoding utf-8 + -cookiejar {} } # We need a useragent string of this style or various servers will refuse to # send us compressed content even when we ask for it. This follows the @@ -86,6 +87,9 @@ namespace eval http { set defaultKeepalive 0 } + # Regular expression used to parse cookies + variable CookieRE {\s*([^][\u0000- ()<>@,;:\\""/?={}\u0100-\uffff]+)=([!\u0023-+\u002D-:<-\u005B\u005D-~]+)(?:\s*;\s*([^\u0000]+))?} + namespace export geturl config reset wait formatQuery register unregister # Useful, but not exported: data size status code } @@ -498,8 +502,12 @@ proc http::geturl {url args} { } return -code error "Illegal characters in URL path" } + if {![regexp {^[^?#]+} $srvurl state(path)]} { + set state(path) / + } } else { set srvurl / + set state(path) / } if {$proto eq ""} { set proto http @@ -719,6 +727,19 @@ proc http::geturl {url args} { seek $state(-querychannel) $start } + if {$http(-cookiejar) ne ""} { + set cookies "" + set separator "" + foreach {key value} [{*}$http(-cookiejar) \ + getCookies $proto $host $port $state(path)] { + append cookies $separator $key = $value + set separator "; " + } + if {$cookies ne ""} { + puts $sock "Cookie: $cookies" + } + } + # Flush the request header and set up the fileevent that will either # push the POST data or read the response. # @@ -955,6 +976,7 @@ proc http::Write {token} { # Read the socket and handle callbacks. proc http::Event {sock token} { + variable http variable $token upvar 0 $token state @@ -1058,6 +1080,11 @@ proc http::Event {sock token} { set state(connection) \ [string trim [string tolower $value]] } + set-cookie { + if {$http(-cookiejar) ne ""} { + ParseCookie $token $value + } + } } lappend state(meta) $key [string trim $value] } @@ -1147,6 +1174,72 @@ proc http::Event {sock token} { } } +proc http::ParseCookie {token value} { + variable http + variable CookieRE + variable $token + upvar 0 $token state + + if {![regexp $CookieRE $value -> name val opts]} { + # Bad cookie! No biscuit! + return + } + + # Convert the options into a list before feeding into the cookie store; + # ugly, but quite easy. + set realopts {persistent 0 hostonly 1} + foreach opt [split [regsub -all {;\s+} [string trimright $opts] {\u0000}] \u0000] { + switch -glob -- $opt { + Expires=* { + set opt [string range $opt 8 end] + if {[catch { + #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 { + #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=* { + # Normalize + 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=* { + set opt [string range $opt 7 end] + set opt [string trimleft $opt "."] + # TODO - Domain safety check! + if {$opt ne ""} { + dict set realopts domain $opt + } + } + Path=* { + set opt [string range $opt 5 end] + if {![string match /* $opt]} { + set opt $state(path) + } + dict set realopts path $opt + } + Secure - HttpOnly { + dict set realopts [string tolower $opt] 1 + } + } + } + {*}$http(-cookiejar) storeCookie $token $name $val $realopts +} + # http::getTextLine -- # # Get one line with the stream in blocking crlf mode diff --git a/tests/http.test b/tests/http.test index 37d4a05..daddf2c 100644 --- a/tests/http.test +++ b/tests/http.test @@ -79,7 +79,7 @@ if {[catch {package present Thread}] == 0 && [file exists $httpdFile]} { test http-1.1 {http::config} { http::config -useragent UserAgent http::config -} [list -accept */* -proxyfilter http::ProxyRequired -proxyhost {} -proxyport {} -urlencoding utf-8 -useragent "UserAgent"] +} [list -accept */* -cookiejar {} -proxyfilter http::ProxyRequired -proxyhost {} -proxyport {} -urlencoding utf-8 -useragent "UserAgent"] test http-1.2 {http::config} { http::config -proxyfilter } http::ProxyRequired @@ -94,10 +94,10 @@ test http-1.4 {http::config} { set x [http::config] http::config {*}$savedconf set x -} {-accept */* -proxyfilter myFilter -proxyhost nowhere.come -proxyport 8080 -urlencoding iso8859-1 -useragent {Tcl Test Suite}} +} {-accept */* -cookiejar {} -proxyfilter myFilter -proxyhost nowhere.come -proxyport 8080 -urlencoding iso8859-1 -useragent {Tcl Test Suite}} test http-1.5 {http::config} -returnCodes error -body { http::config -proxyhost {} -junk 8080 -} -result {Unknown option -junk, must be: -accept, -proxyfilter, -proxyhost, -proxyport, -urlencoding, -useragent} +} -result {Unknown option -junk, must be: -accept, -cookiejar, -proxyfilter, -proxyhost, -proxyport, -urlencoding, -useragent} test http-1.6 {http::config} -setup { set oldenc [http::config -urlencoding] } -body { -- cgit v0.12 From b9098ee927b24f571428a5bdbd0f73a14c902388 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 8 Jul 2012 11:15:45 +0000 Subject: Make the parsing work with Google. --- library/http/http.tcl | 18 ++++++++++++------ 1 file changed, 12 insertions(+), 6 deletions(-) diff --git a/library/http/http.tcl b/library/http/http.tcl index 7b80524..181c29f 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -88,7 +88,7 @@ namespace eval http { } # Regular expression used to parse cookies - variable CookieRE {\s*([^][\u0000- ()<>@,;:\\""/?={}\u0100-\uffff]+)=([!\u0023-+\u002D-:<-\u005B\u005D-~]+)(?:\s*;\s*([^\u0000]+))?} + variable CookieRE {\s*([^][\u0000- ()<>@,;:\\""/?={}\u0100-\uffff]+)=([!\u0023-+\u002D-:<-\u005B\u005D-~]*)(?:\s*;\s*([^\u0000]+))?} namespace export geturl config reset wait formatQuery register unregister # Useful, but not exported: data size status code @@ -1082,7 +1082,7 @@ proc http::Event {sock token} { } set-cookie { if {$http(-cookiejar) ne ""} { - ParseCookie $token $value + ParseCookie $token [string trim $value] } } } @@ -1180,7 +1180,7 @@ proc http::ParseCookie {token value} { variable $token upvar 0 $token state - if {![regexp $CookieRE $value -> name val opts]} { + if {![regexp $CookieRE $value -> cookiename cookieval opts]} { # Bad cookie! No biscuit! return } @@ -1188,8 +1188,8 @@ 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} - foreach opt [split [regsub -all {;\s+} [string trimright $opts] {\u0000}] \u0000] { - switch -glob -- $opt { + foreach opt [split [regsub -all {;\s+} $opts \u0000] \u0000] { + switch -glob -nocase -- $opt { Expires=* { set opt [string range $opt 8 end] if {[catch { @@ -1198,6 +1198,12 @@ proc http::ParseCookie {token value} { [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 { #Sunday, 06-Nov-94 08:49:37 GMT dict set realopts expires \ [clock scan $opt -format "%A, %d-%b-%y %T %Z"] @@ -1237,7 +1243,7 @@ proc http::ParseCookie {token value} { } } } - {*}$http(-cookiejar) storeCookie $token $name $val $realopts + {*}$http(-cookiejar) storeCookie $token $cookiename $cookieval $realopts } # http::getTextLine -- -- cgit v0.12 From 06cfc731c6abebb8f7d67a737dffb55561298d8e Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 11 Jul 2012 10:52:49 +0000 Subject: Start of implementation of cookiejar package. Not yet working/finished. --- library/http/cookiejar.tcl | 104 +++++++++++++++++++++++++++++++++++++++++++++ library/http/http.tcl | 10 +++-- 2 files changed, 110 insertions(+), 4 deletions(-) create mode 100644 library/http/cookiejar.tcl diff --git a/library/http/cookiejar.tcl b/library/http/cookiejar.tcl new file mode 100644 index 0000000..eb3b67b --- /dev/null +++ b/library/http/cookiejar.tcl @@ -0,0 +1,104 @@ +package require Tcl 8.6 +package require sqlite3 +package provide cookiejar 0.1 + +::oo::class create cookiejar { + variable aid + constructor {{path ""}} { + if {$path eq ""} { + sqlite3 [namespace current]::db :memory: + } else { + sqlite3 [namespace current]::db $path + } + ## FIXME + db eval { + CREATE TABLE IF NOT EXISTS cookies ( + TEXT origin NOT NULL, + TEXT domain, + TEXT key NOT NULL, + TEXT value NOT NULL, + INTEGER expiry NOT NULL) + PRIMARY KEY (origin, key) + } + db eval { + CREATE TEMP TABLE IF NOT EXISTS sessionCookies ( + TEXT origin NOT NULL, + TEXT domain, + TEXT key NOT NULL, + TEXT value NOT NULL) + PRIMARY KEY (origin, key) + } + + set aid [after 60000 [namespace current]::my PurgeCookies] + } + + destructor { + after cancel $aid + db close + } + + method getCookies {proto host port path} { + upvar 1 state state + set result {} + ## TODO: How to handle prefix matches? + db eval { + SELECT key, value FROM cookies WHERE domain = :host + } cookie { + dict set result $key $value + } + db eval { + SELECT key, value FROM sessionCookies WHERE domain = :host + } cookie { + dict set result $key $value + } + db eval { + SELECT key, value FROM cookies WHERE origin = :host + } cookie { + dict set result $key $value + } + db eval { + SELECT key, value FROM sessionCookies WHERE origin = :host + } cookie { + dict set result $key $value + } + return $result + } + + method storeCookie {name val options} { + upvar 1 state state + set now [clock seconds] + dict with options {} + if {!$persistent} { + ### FIXME + db eval { + INSERT OR REPLACE sessionCookies ( + origin, domain, key, value + ) VALUES (:origin, :domain, :key, :value) + } + } elseif {$expires < $now} { + db eval { + DELETE FROM cookies + WHERE domain = :domain AND key = :name + } + db eval { + DELETE FROM sessionCookies + WHERE domain = :domain AND key = :name + } + } else { + ### FIXME + db eval { + INSERT OR REPLACE cookies ( + origin, domain, key, value, expiry + ) VALUES (:origin, :domain, :key, :value, :expiry) + } + } + } + + method PurgeCookies {} { + set aid [after 60000 [namespace current]::my PurgeCookies] + set now [clock seconds] + db eval {DELETE FROM cookies WHERE expiry < :now} + } + + forward Database db +} diff --git a/library/http/http.tcl b/library/http/http.tcl index afc3a0f..4fa39a4 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -673,8 +673,10 @@ proc http::geturl {url args} { puts $sock "$how $srvurl HTTP/$state(-protocol)" puts $sock "Accept: $http(-accept)" array set hdrs $state(-headers) + set state(host) $host if {[info exists hdrs(Host)]} { # Allow Host spoofing. [Bug 928154] + regexp {^[^:]+} $hdrs(Host) state(host) puts $sock "Host: $hdrs(Host)" } elseif {$port == $defport} { # Don't add port in this case, to handle broken servers. [Bug @@ -1191,6 +1193,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} + dict set realopts origin $state(host) foreach opt [split [regsub -all {;\s+} $opts \u0000] \u0000] { switch -glob -nocase -- $opt { Expires=* { @@ -1227,10 +1230,9 @@ proc http::ParseCookie {token value} { } } Domain=* { - set opt [string range $opt 7 end] - set opt [string trimleft $opt "."] + set opt [string trimleft [string range $opt 7 end] "."] # TODO - Domain safety check! - if {$opt ne ""} { + if {$opt ne "" && ![string match *. $opt]} { dict set realopts domain $opt } } @@ -1246,7 +1248,7 @@ proc http::ParseCookie {token value} { } } } - {*}$http(-cookiejar) storeCookie $token $cookiename $cookieval $realopts + {*}$http(-cookiejar) storeCookie $cookiename $cookieval $realopts } # http::getTextLine -- -- cgit v0.12 From db9c41f45c92a3e57a36432431702960a76360d5 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 19 Jul 2012 16:28:50 +0000 Subject: First attempt at a "bad cookie domain" detector, a critical security check. --- library/http/cookiejar.tcl | 182 ++++++++++++++++++++++++++++++++++++--------- 1 file changed, 148 insertions(+), 34 deletions(-) diff --git a/library/http/cookiejar.tcl b/library/http/cookiejar.tcl index eb3b67b..681c923 100644 --- a/library/http/cookiejar.tcl +++ b/library/http/cookiejar.tcl @@ -2,7 +2,13 @@ package require Tcl 8.6 package require sqlite3 package provide cookiejar 0.1 -::oo::class create cookiejar { +namespace eval ::http { + # TODO is this the _right_ list of domains to use? + variable CookiejarDomainList \ + http://mxr.mozilla.org/mozilla-central/source/netwerk/dns/effective_tld_names.dat?raw=1 +} + +::oo::class create ::http::cookiejar { variable aid constructor {{path ""}} { if {$path eq ""} { @@ -11,25 +17,105 @@ package provide cookiejar 0.1 sqlite3 [namespace current]::db $path } ## FIXME + ## Model from Safari: + # * Creation instant + # * Domain + # * Expiration instant + # * Name + # * Path + # * Value + ## Model from Firefox: + # CREATE TABLE moz_cookies ( + # id INTEGER PRIMARY KEY, + # name TEXT, + # value TEXT, + # host TEXT, + # path TEXT, + # expiry INTEGER, + # lastAccessed INTEGER, + # isSecure INTEGER, + # isHttpOnly INTEGER, + # baseDomain TEXT, + # creationTime INTEGER) + # CREATE INDEX moz_basedomain ON moz_cookies (baseDomain) + # CREATE UNIQUE INDEX moz_uniqueid ON moz_cookies (name, host, path) db eval { CREATE TABLE IF NOT EXISTS cookies ( - TEXT origin NOT NULL, - TEXT domain, - TEXT key NOT NULL, - TEXT value NOT NULL, - INTEGER expiry NOT NULL) - PRIMARY KEY (origin, key) + id INTEGER PRIMARY KEY, + origin TEXT NOT NULL, + path TEXT NOT NULL, + domain TEXT, + key TEXT NOT NULL, + value TEXT NOT NULL, + expiry INTEGER NOT NULL); + CREATE UNIQUE INDEX IF NOT EXISTS cookieUnique + ON cookies (origin, path, key) } db eval { CREATE TEMP TABLE IF NOT EXISTS sessionCookies ( - TEXT origin NOT NULL, - TEXT domain, - TEXT key NOT NULL, - TEXT value NOT NULL) - PRIMARY KEY (origin, key) + origin TEXT NOT NULL, + path TEXT NOT NULL, + domain TEXT, + key TEXT NOT NULL, + value TEXT NOT NULL); + CREATE UNIQUE INDEX IF NOT EXISTS sessionUnique + ON sessionCookies (origin, path, key) } set aid [after 60000 [namespace current]::my PurgeCookies] + + if {$path ne ""} { + db transaction { + if {[catch { + db eval {SELECT * FROM forbidden LIMIT 1} + }]} { + my InitDomainList + } + } + } + } + + method InitDomainList {} { + db eval { + CREATE TABLE IF NOT EXISTS forbidden ( + domain TEXT PRIMARY KEY); + CREATE TABLE IF NOT EXISTS forbiddenSuper ( + domain TEXT PRIMARY KEY); + CREATE TABLE IF NOT EXISTS permitted ( + domain TEXT PRIMARY KEY); + } + set tok [http::geturl $::http::CookiejarDomainList] + try { + if {[http::ncode $tok] == 200} { + foreach line [split [http::data $tok] \n] { + if {[string trim $line] eq ""} continue + if {[string match //* $line]} continue + if {[string match !* $line]} { + set line [string range $line 1 end] + db eval { + INSERT INTO permitted (domain) + VALUES (:line) + } + } else { + if {[string match {\*.*} $line]} { + set line [string range $line 2 end] + db eval { + INSERT INTO forbiddenSuper (domain) + VALUES (:line) + } + } + db eval { + INSERT INTO forbidden (domain) + VALUES (:line) + } + } + } + } else { + http::Log "Warning: failed to fetch list of forbidden cookie domains" + } + } finally { + http::cleanup $tok + } } destructor { @@ -41,6 +127,8 @@ package provide cookiejar 0.1 upvar 1 state state set result {} ## TODO: How to handle prefix matches? +# From kbk +#LENGTH(theColumn) <= LENGTH(:queryStr) AND SUBSTR(theColumn, LENGTH(:queryStr)-LENGTH(theColumn)+1) = :queryStr db eval { SELECT key, value FROM cookies WHERE domain = :host } cookie { @@ -64,32 +152,56 @@ package provide cookiejar 0.1 return $result } + method BadDomain options { + if {![dict exists $options domain]} { + return 0 + } + set domain [dict get $options domain] + db eval { + SELECT domain FROM permitted WHERE domain == :domain + } x {return 0} + db eval { + SELECT domain FROM forbidden WHERE domain == :domain + } x {return 1} + if {![regexp {^[^.]+\.(.+)$} $domain -> super]} {return 1} + db eval { + SELECT domain FROM forbiddenSuper WHERE domain == :domain + } x {return 1} + return 0 + } + method storeCookie {name val options} { upvar 1 state state set now [clock seconds] - dict with options {} - if {!$persistent} { - ### FIXME - db eval { - INSERT OR REPLACE sessionCookies ( - origin, domain, key, value - ) VALUES (:origin, :domain, :key, :value) - } - } elseif {$expires < $now} { - db eval { - DELETE FROM cookies - WHERE domain = :domain AND key = :name + db transaction { + if {[my BadDomain $options]} { + http::Log "Warning: evil cookie detected" + return } - db eval { - DELETE FROM sessionCookies - WHERE domain = :domain AND key = :name - } - } else { - ### FIXME - db eval { - INSERT OR REPLACE cookies ( - origin, domain, key, value, expiry - ) VALUES (:origin, :domain, :key, :value, :expiry) + dict with options {} + if {!$persistent} { + ### FIXME + db eval { + INSERT OR REPLACE sessionCookies ( + origin, domain, key, value) + VALUES (:origin, :domain, :key, :value) + } + } elseif {$expires < $now} { + db eval { + DELETE FROM cookies + WHERE domain = :domain AND key = :name AND path = :path + } + db eval { + DELETE FROM sessionCookies + WHERE domain = :domain AND key = :name AND path = :path + } + } else { + ### FIXME + db eval { + INSERT OR REPLACE cookies ( + origin, domain, key, value, expiry) + VALUES (:origin, :domain, :key, :value, :expiry) + } } } } @@ -98,6 +210,8 @@ package provide cookiejar 0.1 set aid [after 60000 [namespace current]::my PurgeCookies] set now [clock seconds] db eval {DELETE FROM cookies WHERE expiry < :now} + ### TODO: Cap the total number of cookies and session cookies, + ### purging least frequently used } forward Database db -- cgit v0.12 From 99af655c4c86349d99454dd9c6879ec83e32f1f2 Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 31 Jul 2012 10:52:29 +0000 Subject: some small tinkerings --- library/http/cookiejar.tcl | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/library/http/cookiejar.tcl b/library/http/cookiejar.tcl index be446a1..e6c1e85 100644 --- a/library/http/cookiejar.tcl +++ b/library/http/cookiejar.tcl @@ -42,9 +42,9 @@ namespace eval ::http { db eval { CREATE TABLE IF NOT EXISTS cookies ( id INTEGER PRIMARY KEY, - origin TEXT NOT NULL, + origin TEXT NOT NULL COLLATE NOCASE, path TEXT NOT NULL, - domain TEXT, + domain TEXT COLLATE NOCASE, key TEXT NOT NULL, value TEXT NOT NULL, expiry INTEGER NOT NULL); @@ -53,9 +53,9 @@ namespace eval ::http { } db eval { CREATE TEMP TABLE IF NOT EXISTS sessionCookies ( - origin TEXT NOT NULL, + origin TEXT NOT NULL COLLATE NOCASE, path TEXT NOT NULL, - domain TEXT, + domain TEXT COLLATE NOCASE, key TEXT NOT NULL, value TEXT NOT NULL); CREATE UNIQUE INDEX IF NOT EXISTS sessionUnique @@ -66,9 +66,11 @@ namespace eval ::http { if {$path ne ""} { db transaction { - if {[catch { - db eval {SELECT * FROM forbidden LIMIT 1} - }]} { + db eval { + SELECT count(*) AS present FROM sqlite_master + WHERE type='table' AND name='forbidden' + } + if {!$present} { my InitDomainList } } -- cgit v0.12 From bdafa7afcb41f8ba37aea8338559c0673dc6688e Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 2 Sep 2012 07:28:02 +0000 Subject: Add package index entry. --- library/http/pkgIndex.tcl | 1 + 1 file changed, 1 insertion(+) diff --git a/library/http/pkgIndex.tcl b/library/http/pkgIndex.tcl index d51f8a8..5ce5c37 100644 --- a/library/http/pkgIndex.tcl +++ b/library/http/pkgIndex.tcl @@ -1,2 +1,3 @@ if {![package vsatisfies [package provide Tcl] 8.6]} {return} package ifneeded http 2.8.4 [list tclPkgSetup $dir http 2.8.4 {{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 tclPkgSetup $dir cookiejar 0.1 {{cookiejar.tcl source {::http::cookiejar}}}] -- cgit v0.12 From 51e67d70c40f25577a399ae06cfad0484bb58020 Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 4 Sep 2012 21:24:43 +0000 Subject: Improving the cookie lookup code to actually handle paths&domains --- library/http/cookiejar.tcl | 85 +++++++++++++++++++++++++++------------------- 1 file changed, 50 insertions(+), 35 deletions(-) diff --git a/library/http/cookiejar.tcl b/library/http/cookiejar.tcl index e6c1e85..4e67f95 100644 --- a/library/http/cookiejar.tcl +++ b/library/http/cookiejar.tcl @@ -78,6 +78,7 @@ namespace eval ::http { } method InitDomainList {} { + variable ::http::CookiejarDomainList db eval { CREATE TABLE IF NOT EXISTS forbidden ( domain TEXT PRIMARY KEY); @@ -86,7 +87,8 @@ namespace eval ::http { CREATE TABLE IF NOT EXISTS permitted ( domain TEXT PRIMARY KEY); } - set tok [http::geturl $::http::CookiejarDomainList] + http::Log "Loading domain list from $CookiejarDomainList" + set tok [http::geturl $CookiejarDomainList] try { if {[http::ncode $tok] == 200} { foreach line [split [http::data $tok] \n] { @@ -96,19 +98,19 @@ namespace eval ::http { set line [string range $line 1 end] db eval { INSERT INTO permitted (domain) - VALUES (:line) + VALUES ($line) } } else { if {[string match {\*.*} $line]} { set line [string range $line 2 end] db eval { INSERT INTO forbiddenSuper (domain) - VALUES (:line) + VALUES ($line) } } db eval { INSERT INTO forbidden (domain) - VALUES (:line) + VALUES ($line) } } } @@ -125,32 +127,44 @@ namespace eval ::http { db close } + method GetCookiesForHostAndPath {result host path} { + upvar 1 $result result + db eval { + SELECT key, value FROM cookies + WHERE domain = $host AND path = $path + } cookie { + dict set result $cookie(key) $cookie(value) + } + db eval { + SELECT key, value FROM sessionCookies + WHERE domain = $host AND path = $path + } cookie { + dict set result $cookie(key) $cookie(value) + } + } method getCookies {proto host port path} { upvar 1 state state set result {} - ## TODO: How to handle prefix matches? -# From kbk -#LENGTH(theColumn) <= LENGTH(:queryStr) AND SUBSTR(theColumn, LENGTH(:queryStr)-LENGTH(theColumn)+1) = :queryStr db transaction { - db eval { - SELECT key, value FROM cookies WHERE domain = :host - } cookie { - dict set result $key $value - } - db eval { - SELECT key, value FROM sessionCookies WHERE domain = :host - } cookie { - dict set result $key $value - } - db eval { - SELECT key, value FROM cookies WHERE origin = :host - } cookie { - dict set result $key $value - } - db eval { - SELECT key, value FROM sessionCookies WHERE origin = :host - } cookie { - dict set result $key $value + # 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 + set pathbits [split [string trimleft $path "/"] "/"] + set hostbits [split $host "."] + if {[regexp {[^0-9.]} $host]} { + for {set i [llength $hostbits]} {[incr i -1] >= 0} {} { + set domain [join [lrange $hostbits $i end] "."] + for {set j -1} {$j < [llength $pathbits]} {incr j} { + set p /[join [lrange $pathbits 0 $j] "/"] + my GetCookiesForHostAndPath result $domain $p + } + } + } else { + for {set j -1} {$j < [llength $pathbits]} {incr j} { + set p /[join [lrange $pathbits 0 $j] "/"] + my GetCookiesForHostAndPath result $host $p + } } } return $result @@ -162,15 +176,16 @@ namespace eval ::http { } set domain [dict get $options domain] db eval { - SELECT domain FROM permitted WHERE domain == :domain + SELECT domain FROM permitted WHERE domain == $domain } x {return 0} db eval { - SELECT domain FROM forbidden WHERE domain == :domain - } x {return 1} - if {![regexp {^[^.]+\.(.+)$} $domain -> super]} {return 1} - db eval { - SELECT domain FROM forbiddenSuper WHERE domain == :domain + SELECT domain FROM forbidden WHERE domain == $domain } x {return 1} + if {[regexp {^[^.]+\.(.+)$} $domain -> super]} { + db eval { + SELECT domain FROM forbiddenSuper WHERE domain == $super + } x {return 1} + } return 0 } @@ -188,16 +203,16 @@ namespace eval ::http { db eval { INSERT OR REPLACE sessionCookies ( origin, domain, key, value) - VALUES (:origin, :domain, :key, :value) + VALUES ($origin, $domain, $key, $value) } } elseif {$expires < $now} { db eval { DELETE FROM cookies - WHERE domain = :domain AND key = :name AND path = :path + WHERE domain = $domain AND key = $name AND path = $path } db eval { DELETE FROM sessionCookies - WHERE domain = :domain AND key = :name AND path = :path + WHERE domain = $domain AND key = $name AND path = $path } } else { ### FIXME -- cgit v0.12 From fa56a98ba9b5e567d53181939645c71ccdfc6cfc Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 5 Sep 2012 09:46:03 +0000 Subject: more realistic queries --- library/http/cookiejar.tcl | 92 ++++++++++++++++++++++++++++++---------------- library/http/http.tcl | 3 +- 2 files changed, 63 insertions(+), 32 deletions(-) diff --git a/library/http/cookiejar.tcl b/library/http/cookiejar.tcl index 4e67f95..054698f 100644 --- a/library/http/cookiejar.tcl +++ b/library/http/cookiejar.tcl @@ -9,13 +9,14 @@ namespace eval ::http { } ::oo::class create ::http::cookiejar { - variable aid + variable aid deletions constructor {{path ""}} { if {$path eq ""} { sqlite3 [namespace current]::db :memory: } else { sqlite3 [namespace current]::db $path } + set deletions 0 ## FIXME ## Model from Safari: # * Creation instant @@ -62,15 +63,21 @@ namespace eval ::http { ON sessionCookies (origin, path, key) } + db eval { + SELECT COUNT(*) AS cookieCount FROM cookies + } + if {$cookieCount} { + http::Log "loaded cookie store from $path with $cookieCount entries" + } + set aid [after 60000 [namespace current]::my PurgeCookies] if {$path ne ""} { db transaction { - db eval { - SELECT count(*) AS present FROM sqlite_master + if {![db exists { + SELECT 1 FROM sqlite_master WHERE type='table' AND name='forbidden' - } - if {!$present} { + }]} then { my InitDomainList } } @@ -149,7 +156,7 @@ namespace eval ::http { # 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 + #LENGTH(theColumn) <= LENGTH($queryStr) AND SUBSTR(theColumn, LENGTH($queryStr) LENGTH(theColumn)+1) = $queryStr set pathbits [split [string trimleft $path "/"] "/"] set hostbits [split $host "."] if {[regexp {[^0-9.]} $host]} { @@ -174,21 +181,37 @@ namespace eval ::http { if {![dict exists $options domain]} { return 0 } - set domain [dict get $options domain] - db eval { - SELECT domain FROM permitted WHERE domain == $domain - } x {return 0} - db eval { - SELECT domain FROM forbidden WHERE domain == $domain - } x {return 1} + dict with options {} + if {$domain ne $origin} { + http::Log "cookie domain varies from origin ($domain, $origin)" + } + if {[db exists { + SELECT 1 FROM permitted WHERE domain = $domain + }]} {return 0} + if {[db exists { + SELECT 1 FROM forbidden WHERE domain = $domain + }]} {return 1} if {[regexp {^[^.]+\.(.+)$} $domain -> super]} { - db eval { - SELECT domain FROM forbiddenSuper WHERE domain == $super - } x {return 1} + if {[db exists { + SELECT 1 FROM forbiddenSuper WHERE domain = $super + }]} {return 1} } return 0 } + method DeleteCookie {domain path key} { + db eval { + DELETE FROM cookies + WHERE domain = $domain AND key = $name AND path = $path + } + incr deletions [db changes] + db eval { + DELETE FROM sessionCookies + WHERE domain = $domain AND key = $name AND path = $path + } + incr deletions [db changes] + http::Log "deleted cookies for $domain, $path, $path" + } method storeCookie {name val options} { upvar 1 state state set now [clock seconds] @@ -201,26 +224,21 @@ namespace eval ::http { if {!$persistent} { ### FIXME db eval { - INSERT OR REPLACE sessionCookies ( - origin, domain, key, value) - VALUES ($origin, $domain, $key, $value) + INSERT OR REPLACE INTO sessionCookies ( + origin, domain, path, key, value) + VALUES ($origin, $domain, $path, $key, $value) } + http::Log "defined session cookie for $domain, $path, $key" } elseif {$expires < $now} { - db eval { - DELETE FROM cookies - WHERE domain = $domain AND key = $name AND path = $path - } - db eval { - DELETE FROM sessionCookies - WHERE domain = $domain AND key = $name AND path = $path - } + my DeleteCookie $domain $path $key } else { ### FIXME db eval { - INSERT OR REPLACE cookies ( - origin, domain, key, value, expiry) - VALUES (:origin, :domain, :key, :value, :expiry) + INSERT OR REPLACE INTO cookies ( + origin, domain, path, key, value, expiry) + VALUES ($origin, $domain, $path, $key, $value, $expires) } + http::Log "defined persistent cookie for $domain, $path, $key expires at [clock format $expires]" } } } @@ -228,7 +246,19 @@ namespace eval ::http { method PurgeCookies {} { set aid [after 60000 [namespace current]::my PurgeCookies] set now [clock seconds] - db eval {DELETE FROM cookies WHERE expiry < :now} + http::Log "purging cookies that expired before [clock format $now]" + db transaction { + db eval { + DELETE FROM cookies WHERE expiry < $now + } + incr deletions [db changes] + if {$deletions > 100} { + set deletions 0 + db eval { + VACUUM + } + } + } ### TODO: Cap the total number of cookies and session cookies, ### purging least frequently used } diff --git a/library/http/http.tcl b/library/http/http.tcl index 4fa39a4..e434a45 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -1192,8 +1192,9 @@ 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} + set realopts {persistent 0 hostonly 1 path /} dict set realopts origin $state(host) + dict set realopts domain $state(host) foreach opt [split [regsub -all {;\s+} $opts \u0000] \u0000] { switch -glob -nocase -- $opt { Expires=* { -- cgit v0.12 From 8d9808cb4d764dfccb1a35db84a1ad6a58b31f70 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 5 Sep 2012 10:24:05 +0000 Subject: closer to working --- library/http/cookiejar.tcl | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/library/http/cookiejar.tcl b/library/http/cookiejar.tcl index 054698f..bd85b46 100644 --- a/library/http/cookiejar.tcl +++ b/library/http/cookiejar.tcl @@ -1,4 +1,5 @@ package require Tcl 8.6 +package require http 2.8.4 package require sqlite3 package provide cookiejar 0.1 @@ -66,7 +67,7 @@ namespace eval ::http { db eval { SELECT COUNT(*) AS cookieCount FROM cookies } - if {$cookieCount} { + if {[info exist cookieCount] && $cookieCount} { http::Log "loaded cookie store from $path with $cookieCount entries" } @@ -134,8 +135,8 @@ namespace eval ::http { db close } - method GetCookiesForHostAndPath {result host path} { - upvar 1 $result result + method GetCookiesForHostAndPath {*result host path} { + upvar 1 ${*result} result db eval { SELECT key, value FROM cookies WHERE domain = $host AND path = $path -- cgit v0.12 From a23ee46c675547eb49015e946884b841c71d8331 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 6 Sep 2012 09:49:52 +0000 Subject: improve logging, correct 'secure' property handling, correct domain handling, simplify http<->cookiejar interface --- library/http/cookiejar.tcl | 267 +++++++++++++++++++++++++++------------------ library/http/http.tcl | 14 ++- 2 files changed, 171 insertions(+), 110 deletions(-) diff --git a/library/http/cookiejar.tcl b/library/http/cookiejar.tcl index bd85b46..30720f8 100644 --- a/library/http/cookiejar.tcl +++ b/library/http/cookiejar.tcl @@ -1,92 +1,96 @@ -package require Tcl 8.6 -package require http 2.8.4 +package require Tcl 8.5 +package require TclOO +package require http 2.7;#2.8.4 package require sqlite3 -package provide cookiejar 0.1 namespace eval ::http { - # TODO is this the _right_ list of domains to use? - variable CookiejarDomainList \ + # TODO: is this the _right_ list of domains to use? + variable cookiejar_domainlist \ http://mxr.mozilla.org/mozilla-central/source/netwerk/dns/effective_tld_names.dat?raw=1 + variable cookiejar_version 0.1 + variable cookiejar_loglevel info } ::oo::class create ::http::cookiejar { + self { + method log {origin level msg} { + upvar 0 ::http::cookiejar_loglevel loglevel + set map {debug 0 info 1 warn 2 error 3} + if {[string map $map $level] >= [string map $map $loglevel]} { + ::http::Log [string toupper $level]:cookiejar($origin):${msg} + } + } + method loglevel {level} { + upvar 0 ::http::cookiejar_loglevel loglevel + if {$level in {debug info warn error}} { + set loglevel $level + } else { + return -code error "unknown log level \"$level\": must be debug, info, warn, or error" + } + } + } + variable aid deletions constructor {{path ""}} { if {$path eq ""} { sqlite3 [namespace current]::db :memory: } else { sqlite3 [namespace current]::db $path + db timeout 500 } + proc log {level msg} "::http::cookiejar log [list [self]] \$level \$msg" set deletions 0 - ## FIXME - ## Model from Safari: - # * Creation instant - # * Domain - # * Expiration instant - # * Name - # * Path - # * Value - ## Model from Firefox: - # CREATE TABLE moz_cookies ( - # id INTEGER PRIMARY KEY, - # name TEXT, - # value TEXT, - # host TEXT, - # path TEXT, - # expiry INTEGER, - # lastAccessed INTEGER, - # isSecure INTEGER, - # isHttpOnly INTEGER, - # baseDomain TEXT, - # creationTime INTEGER) - # CREATE INDEX moz_basedomain ON moz_cookies (baseDomain) - # CREATE UNIQUE INDEX moz_uniqueid ON moz_cookies (name, host, path) db eval { CREATE TABLE IF NOT EXISTS cookies ( id INTEGER PRIMARY KEY, - origin TEXT NOT NULL COLLATE NOCASE, + secure INTEGER NOT NULL, + domain TEXT NOT NULL COLLATE NOCASE, path TEXT NOT NULL, - domain TEXT COLLATE NOCASE, key TEXT NOT NULL, value TEXT NOT NULL, + originonly INTEGER NOT NULL, expiry INTEGER NOT NULL); CREATE UNIQUE INDEX IF NOT EXISTS cookieUnique - ON cookies (origin, path, key) + ON cookies (secure, domain, path, key) } db eval { - CREATE TEMP TABLE IF NOT EXISTS sessionCookies ( - origin TEXT NOT NULL COLLATE NOCASE, + CREATE TEMP TABLE sessionCookies ( + id INTEGER PRIMARY KEY, + secure INTEGER NOT NULL, + domain TEXT NOT NULL COLLATE NOCASE, path TEXT NOT NULL, - domain TEXT COLLATE NOCASE, key TEXT NOT NULL, + originonly INTEGER NOT NULL, value TEXT NOT NULL); - CREATE UNIQUE INDEX IF NOT EXISTS sessionUnique - ON sessionCookies (origin, path, key) + CREATE UNIQUE INDEX sessionUnique + ON sessionCookies (secure, domain, path, key) } db eval { SELECT COUNT(*) AS cookieCount FROM cookies } if {[info exist cookieCount] && $cookieCount} { - http::Log "loaded cookie store from $path with $cookieCount entries" + log info "loaded cookie store from $path with $cookieCount entries" } set aid [after 60000 [namespace current]::my PurgeCookies] + # TODO: domain list refresh policy if {$path ne ""} { - db transaction { - if {![db exists { - SELECT 1 FROM sqlite_master - WHERE type='table' AND name='forbidden' - }]} then { - my InitDomainList - } + if {![db exists { + SELECT 1 FROM sqlite_master + WHERE type='table' AND name='forbidden' + }] && ![db exists { + SELECT 1 FROM forbidden + }]} then { + my InitDomainList } } } - + method InitDomainList {} { - variable ::http::CookiejarDomainList + # TODO: Handle IDNs (but Tcl overall gets that wrong at the moment...) + variable ::http::cookiejar_domainlist db eval { CREATE TABLE IF NOT EXISTS forbidden ( domain TEXT PRIMARY KEY); @@ -95,35 +99,37 @@ namespace eval ::http { CREATE TABLE IF NOT EXISTS permitted ( domain TEXT PRIMARY KEY); } - http::Log "Loading domain list from $CookiejarDomainList" - set tok [http::geturl $CookiejarDomainList] + log debug "loading domain list from $cookiejar_domainlist" + set tok [http::geturl $cookiejar_domainlist] try { if {[http::ncode $tok] == 200} { - foreach line [split [http::data $tok] \n] { - if {[string trim $line] eq ""} continue - if {[string match //* $line]} continue - if {[string match !* $line]} { - set line [string range $line 1 end] - db eval { - INSERT INTO permitted (domain) - VALUES ($line) - } - } else { - if {[string match {\*.*} $line]} { - set line [string range $line 2 end] + db transaction { + foreach line [split [http::data $tok] \n] { + if {[string trim $line] eq ""} continue + if {[string match //* $line]} continue + if {[string match !* $line]} { + set line [string range $line 1 end] db eval { - INSERT INTO forbiddenSuper (domain) + INSERT INTO permitted (domain) + VALUES ($line) + } + } else { + if {[string match {\*.*} $line]} { + set line [string range $line 2 end] + db eval { + INSERT INTO forbiddenSuper (domain) VALUES ($line) + } } - } - db eval { - INSERT INTO forbidden (domain) + db eval { + INSERT INTO forbidden (domain) VALUES ($line) + } } } } } else { - http::Log "Warning: failed to fetch list of forbidden cookie domains" + log error "failed to fetch list of forbidden cookie domains from $cookiejar_domainlist" } } finally { http::cleanup $tok @@ -135,43 +141,71 @@ namespace eval ::http { db close } - method GetCookiesForHostAndPath {*result host path} { + method RenderLocation {secure domain path {key ""}} { + if {$key eq ""} { + format "%s://%s%s" [expr {$secure?"https":"http"}] $domain $path + } else { + format "%s://%s%s?%s" \ + [expr {$secure?"https":"http"}] $domain $path $key + } + } + + method GetCookiesForHostAndPath {*result secure host path fullhost} { upvar 1 ${*result} result + log debug "check for cookies for [my RenderLocation $secure $host $path]" db eval { SELECT key, value FROM cookies - WHERE domain = $host AND path = $path + WHERE secure <= $secure AND domain = $host AND path = $path + AND (NOT originonly OR domain = $fullhost) } cookie { - dict set result $cookie(key) $cookie(value) + lappend result $cookie(key) $cookie(value) } db eval { SELECT key, value FROM sessionCookies - WHERE domain = $host AND path = $path + WHERE secure <= $secure AND domain = $host AND path = $path + AND (NOT originonly OR domain = $fullhost) } cookie { - dict set result $cookie(key) $cookie(value) + lappend result $cookie(key) $cookie(value) + } + } + + method SplitDomain domain { + set pieces [split $domain "."] + for {set i [llength $pieces]} {[incr i -1] >= 0} {} { + lappend result [join [lrange $pieces $i end] "."] } + return $result } - method getCookies {proto host port path} { + method 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 + } + + method getCookies {proto host path} { upvar 1 state state set result {} - db transaction { - # 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 - set pathbits [split [string trimleft $path "/"] "/"] - set hostbits [split $host "."] - if {[regexp {[^0-9.]} $host]} { - for {set i [llength $hostbits]} {[incr i -1] >= 0} {} { - set domain [join [lrange $hostbits $i end] "."] - for {set j -1} {$j < [llength $pathbits]} {incr j} { - set p /[join [lrange $pathbits 0 $j] "/"] - my GetCookiesForHostAndPath result $domain $p + set paths [my SplitPath $path] + set domains [my SplitDomain $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 + if {[regexp {[^0-9.]} $host]} { + db transaction { + foreach domain $domains { + foreach p $paths { + my GetCookiesForHostAndPath result $secure $domain $p $host } } - } else { - for {set j -1} {$j < [llength $pathbits]} {incr j} { - set p /[join [lrange $pathbits 0 $j] "/"] - my GetCookiesForHostAndPath result $host $p + } + } else { + db transaction { + foreach p $paths { + my GetCookiesForHostAndPath result $secure $host $p $host } } } @@ -184,41 +218,55 @@ namespace eval ::http { } dict with options {} if {$domain ne $origin} { - http::Log "cookie domain varies from origin ($domain, $origin)" + log debug "cookie domain varies from origin ($domain, $origin)" + } + 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 } if {[db exists { SELECT 1 FROM permitted WHERE domain = $domain }]} {return 0} if {[db exists { SELECT 1 FROM forbidden WHERE domain = $domain - }]} {return 1} + }]} { + log warn "bad cookie: for a forbidden address" + return 1 + } if {[regexp {^[^.]+\.(.+)$} $domain -> super]} { if {[db exists { SELECT 1 FROM forbiddenSuper WHERE domain = $super - }]} {return 1} + }]} { + log warn "bad cookie: for a forbidden address" + return 1 + } } return 0 } - method DeleteCookie {domain path key} { + method DeleteCookie {secure domain path key} { db eval { DELETE FROM cookies - WHERE domain = $domain AND key = $name AND path = $path + WHERE secure <= $secure AND domain = $domain AND path = $path AND key = $key } - incr deletions [db changes] + set del [db changes] db eval { DELETE FROM sessionCookies - WHERE domain = $domain AND key = $name AND path = $path + WHERE secure <= $secure AND domain = $domain AND path = $path AND key = $key } - incr deletions [db changes] - http::Log "deleted cookies for $domain, $path, $path" + incr deletions [incr del [db changes]] + log debug "deleted $del cookies for [my RenderLocation $secure $domain $path $key]" } + method storeCookie {name val options} { upvar 1 state state set now [clock seconds] db transaction { if {[my BadDomain $options]} { - http::Log "Warning: evil cookie detected" return } dict with options {} @@ -226,20 +274,24 @@ namespace eval ::http { ### FIXME db eval { INSERT OR REPLACE INTO sessionCookies ( - origin, domain, path, key, value) - VALUES ($origin, $domain, $path, $key, $value) + secure, domain, path, key, value, originonly) + VALUES ($secure, $domain, $path, $key, $value, $hostonly); + DELETE FROM cookies + WHERE secure <= $secure AND domain = $domain AND path = $path AND key = $key } - http::Log "defined session cookie for $domain, $path, $key" + log debug "defined session cookie for [my RenderLocation $secure $domain $path $key]" } elseif {$expires < $now} { - my DeleteCookie $domain $path $key + my DeleteCookie $secure $domain $path $key } else { ### FIXME db eval { INSERT OR REPLACE INTO cookies ( - origin, domain, path, key, value, expiry) - VALUES ($origin, $domain, $path, $key, $value, $expires) + secure, domain, path, key, value, originonly, expiry) + VALUES ($secure, $domain, $path, $key, $value, $hostonly, $expires); + DELETE FROM sessionCookies + WHERE secure <= $secure AND domain = $domain AND path = $path AND key = $key } - http::Log "defined persistent cookie for $domain, $path, $key expires at [clock format $expires]" + log debug "defined persistent cookie for [my RenderLocation $secure $host $path $key], expires at [clock format $expires]" } } } @@ -247,7 +299,7 @@ namespace eval ::http { method PurgeCookies {} { set aid [after 60000 [namespace current]::my PurgeCookies] set now [clock seconds] - http::Log "purging cookies that expired before [clock format $now]" + log debug "purging cookies that expired before [clock format $now]" db transaction { db eval { DELETE FROM cookies WHERE expiry < $now @@ -255,6 +307,7 @@ namespace eval ::http { incr deletions [db changes] if {$deletions > 100} { set deletions 0 + log debug "vacuuming cookie database" db eval { VACUUM } @@ -266,3 +319,5 @@ namespace eval ::http { forward Database db } + +package provide cookiejar $::http::cookiejar_version diff --git a/library/http/http.tcl b/library/http/http.tcl index e434a45..746603f 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -88,7 +88,7 @@ namespace eval http { } # Regular expression used to parse cookies - variable CookieRE {\s*([^][\u0000- ()<>@,;:\\""/?={}\u0100-\uffff]+)=([!\u0023-+\u002D-:<-\u005B\u005D-~]*)(?:\s*;\s*([^\u0000]+))?} + variable CookieRE {\s*([^][\u0000- ()<>@,;:\\""/?={}\u007f-\uffff]+)=([!\u0023-+\u002D-:<-\u005B\u005D-~]*)(?:\s*;\s*([^\u0000]+))?} namespace export geturl config reset wait formatQuery register unregister # Useful, but not exported: data size status code @@ -732,11 +732,14 @@ proc http::geturl {url args} { seek $state(-querychannel) $start } + # Note that we don't do Cookie2; that's much nastier and not normally + # observed in practice either. It also doesn't fix the multitude of + # bugs in the basic cookie spec. if {$http(-cookiejar) ne ""} { set cookies "" set separator "" foreach {key value} [{*}$http(-cookiejar) \ - getCookies $proto $host $port $state(path)] { + getCookies $proto $host $state(path)] { append cookies $separator $key = $value set separator "; " } @@ -1192,7 +1195,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 /} + set realopts {persistent 0 hostonly 1 path / secure 0} dict set realopts origin $state(host) dict set realopts domain $state(host) foreach opt [split [regsub -all {;\s+} $opts \u0000] \u0000] { @@ -1211,6 +1214,9 @@ proc http::ParseCookie {token value} { [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: + # #Sunday, 06-Nov-94 08:49:37 GMT dict set realopts expires \ [clock scan $opt -format "%A, %d-%b-%y %T %Z"] @@ -1232,9 +1238,9 @@ proc http::ParseCookie {token value} { } Domain=* { set opt [string trimleft [string range $opt 7 end] "."] - # TODO - Domain safety check! if {$opt ne "" && ![string match *. $opt]} { dict set realopts domain $opt + dict set realopts hostonly 0 } } Path=* { -- cgit v0.12 From ddb07346c093db91c8ac9cff07843d135067ac3d Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 6 Sep 2012 19:18:37 +0000 Subject: Tidy up, making code be of higher general quality. --- library/http/cookiejar.tcl | 27 +++++++++++++-------------- library/http/http.tcl | 2 +- 2 files changed, 14 insertions(+), 15 deletions(-) diff --git a/library/http/cookiejar.tcl b/library/http/cookiejar.tcl index 30720f8..9a02834 100644 --- a/library/http/cookiejar.tcl +++ b/library/http/cookiejar.tcl @@ -20,13 +20,14 @@ namespace eval ::http { ::http::Log [string toupper $level]:cookiejar($origin):${msg} } } - method loglevel {level} { + method loglevel {{level "\u0000\u0000"}} { upvar 0 ::http::cookiejar_loglevel loglevel if {$level in {debug info warn error}} { set loglevel $level - } else { + } elseif {$level ne "\u0000\u0000"} { return -code error "unknown log level \"$level\": must be debug, info, warn, or error" } + return $loglevel } } @@ -76,6 +77,14 @@ namespace eval ::http { set aid [after 60000 [namespace current]::my PurgeCookies] # TODO: domain list refresh policy + db eval { + CREATE TABLE IF NOT EXISTS forbidden ( + domain TEXT PRIMARY KEY); + CREATE TABLE IF NOT EXISTS forbiddenSuper ( + domain TEXT PRIMARY KEY); + CREATE TABLE IF NOT EXISTS permitted ( + domain TEXT PRIMARY KEY); + } if {$path ne ""} { if {![db exists { SELECT 1 FROM sqlite_master @@ -91,14 +100,6 @@ namespace eval ::http { method InitDomainList {} { # TODO: Handle IDNs (but Tcl overall gets that wrong at the moment...) variable ::http::cookiejar_domainlist - db eval { - CREATE TABLE IF NOT EXISTS forbidden ( - domain TEXT PRIMARY KEY); - CREATE TABLE IF NOT EXISTS forbiddenSuper ( - domain TEXT PRIMARY KEY); - CREATE TABLE IF NOT EXISTS permitted ( - domain TEXT PRIMARY KEY); - } log debug "loading domain list from $cookiejar_domainlist" set tok [http::geturl $cookiejar_domainlist] try { @@ -150,8 +151,8 @@ namespace eval ::http { } } - method GetCookiesForHostAndPath {*result secure host path fullhost} { - upvar 1 ${*result} result + method GetCookiesForHostAndPath {listVar secure host path fullhost} { + upvar 1 $listVar result log debug "check for cookies for [my RenderLocation $secure $host $path]" db eval { SELECT key, value FROM cookies @@ -185,7 +186,6 @@ namespace eval ::http { } method getCookies {proto host path} { - upvar 1 state state set result {} set paths [my SplitPath $path] set domains [my SplitDomain $host] @@ -263,7 +263,6 @@ namespace eval ::http { } method storeCookie {name val options} { - upvar 1 state state set now [clock seconds] db transaction { if {[my BadDomain $options]} { diff --git a/library/http/http.tcl b/library/http/http.tcl index 746603f..98ed71b 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -1195,7 +1195,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} + set realopts {persistent 0 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] { -- cgit v0.12 From 9e6f2e579a4491d2cbcb251d6b2f098210426be2 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 7 Sep 2012 07:13:44 +0000 Subject: improving the database, working towards a purging algorithm for session cookies --- library/http/cookiejar.tcl | 75 +++++++++++++++++++++++++++++----------------- 1 file changed, 48 insertions(+), 27 deletions(-) diff --git a/library/http/cookiejar.tcl b/library/http/cookiejar.tcl index 9a02834..20ed7a0 100644 --- a/library/http/cookiejar.tcl +++ b/library/http/cookiejar.tcl @@ -17,7 +17,11 @@ namespace eval ::http { upvar 0 ::http::cookiejar_loglevel loglevel set map {debug 0 info 1 warn 2 error 3} if {[string map $map $level] >= [string map $map $loglevel]} { - ::http::Log [string toupper $level]:cookiejar($origin):${msg} + set ms [clock milliseconds] + set ts [expr {$ms / 1000}] + set ms [format %03d [expr {$ms % 1000}]] + set t [clock format $ts -format "%Y%m%dT%H%M%S.${ms}Z" -gmt 1] + ::http::Log ${t}:[string toupper $level]:cookiejar($origin):${msg} } } method loglevel {{level "\u0000\u0000"}} { @@ -39,10 +43,11 @@ namespace eval ::http { sqlite3 [namespace current]::db $path db timeout 500 } - proc log {level msg} "::http::cookiejar log [list [self]] \$level \$msg" + proc log {level msg} \ + "::http::cookiejar log [list [self]] \$level \$msg" set deletions 0 db eval { - CREATE TABLE IF NOT EXISTS cookies ( + CREATE TABLE IF NOT EXISTS persistentCookies ( id INTEGER PRIMARY KEY, secure INTEGER NOT NULL, domain TEXT NOT NULL COLLATE NOCASE, @@ -50,10 +55,14 @@ namespace eval ::http { key TEXT NOT NULL, value TEXT NOT NULL, originonly INTEGER NOT NULL, - expiry INTEGER NOT NULL); - CREATE UNIQUE INDEX IF NOT EXISTS cookieUnique - ON cookies (secure, domain, path, key) + expiry 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); } + ## TODO: Are there "TEMP INDEX"es? db eval { CREATE TEMP TABLE sessionCookies ( id INTEGER PRIMARY KEY, @@ -62,13 +71,17 @@ namespace eval ::http { path TEXT NOT NULL, key TEXT NOT NULL, originonly INTEGER NOT NULL, - value TEXT NOT NULL); + value TEXT NOT NULL, + lastuse INTEGER NOT NULL, + creation INTEGER NOT NULL); CREATE UNIQUE INDEX sessionUnique - ON sessionCookies (secure, domain, path, key) + ON sessionCookies (domain, path, key); + CREATE INDEX sessionLookup ON sessionCookies (domain, path); } + ## TODO: Consider creating a view db eval { - SELECT COUNT(*) AS cookieCount FROM cookies + SELECT COUNT(*) AS cookieCount FROM persistentCookies } if {[info exist cookieCount] && $cookieCount} { log info "loaded cookie store from $path with $cookieCount entries" @@ -155,18 +168,23 @@ namespace eval ::http { upvar 1 $listVar result log debug "check for cookies for [my RenderLocation $secure $host $path]" db eval { - SELECT key, value FROM cookies - WHERE secure <= $secure AND domain = $host AND path = $path + SELECT key, value FROM persistentCookies + WHERE domain = $host AND path = $path AND secure <= $secure AND (NOT originonly OR domain = $fullhost) - } cookie { - lappend result $cookie(key) $cookie(value) + } { + lappend result $key $value } + set now [clock seconds] db eval { - SELECT key, value FROM sessionCookies - WHERE secure <= $secure AND domain = $host AND path = $path + SELECT id, key, value FROM sessionCookies + WHERE domain = $host AND path = $path AND secure <= $secure AND (NOT originonly OR domain = $fullhost) - } cookie { - lappend result $cookie(key) $cookie(value) + } { + lappend result $key $value + ## FIXME: check syntax! + db eval { + UPDATE sessionCookies SET lastuse = $now WHERE id = $id + } } } @@ -250,13 +268,15 @@ namespace eval ::http { method DeleteCookie {secure domain path key} { db eval { - DELETE FROM cookies - WHERE secure <= $secure AND domain = $domain AND path = $path AND key = $key + DELETE FROM persistentCookies + WHERE domain = $domain AND path = $path AND key = $key + AND secure <= $secure } set del [db changes] db eval { DELETE FROM sessionCookies - WHERE secure <= $secure AND domain = $domain AND path = $path AND key = $key + WHERE domain = $domain AND path = $path AND key = $key + AND secure <= $secure } incr deletions [incr del [db changes]] log debug "deleted $del cookies for [my RenderLocation $secure $domain $path $key]" @@ -268,14 +288,15 @@ namespace eval ::http { if {[my BadDomain $options]} { return } + set now [clock seconds] dict with options {} if {!$persistent} { ### FIXME db eval { INSERT OR REPLACE INTO sessionCookies ( - secure, domain, path, key, value, originonly) - VALUES ($secure, $domain, $path, $key, $value, $hostonly); - DELETE FROM cookies + secure, domain, path, key, value, originonly, creation) + VALUES ($secure, $domain, $path, $key, $value, $hostonly, $now); + DELETE FROM persistentCookies WHERE secure <= $secure AND domain = $domain AND path = $path AND key = $key } log debug "defined session cookie for [my RenderLocation $secure $domain $path $key]" @@ -284,9 +305,9 @@ namespace eval ::http { } else { ### FIXME db eval { - INSERT OR REPLACE INTO cookies ( - secure, domain, path, key, value, originonly, expiry) - VALUES ($secure, $domain, $path, $key, $value, $hostonly, $expires); + INSERT OR REPLACE INTO persistentCookies ( + secure, domain, path, key, value, originonly, expiry, creation) + VALUES ($secure, $domain, $path, $key, $value, $hostonly, $expires, $now); DELETE FROM sessionCookies WHERE secure <= $secure AND domain = $domain AND path = $path AND key = $key } @@ -301,7 +322,7 @@ namespace eval ::http { log debug "purging cookies that expired before [clock format $now]" db transaction { db eval { - DELETE FROM cookies WHERE expiry < $now + DELETE FROM persistentCookies WHERE expiry < $now } incr deletions [db changes] if {$deletions > 100} { -- cgit v0.12 From ee1f2a248415d2bef750da1b3622983c2432cc54 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 7 Sep 2012 10:35:14 +0000 Subject: More improvements --- library/http/cookiejar.tcl | 218 ++++++++++++++++++++++++++------------------- 1 file changed, 128 insertions(+), 90 deletions(-) diff --git a/library/http/cookiejar.tcl b/library/http/cookiejar.tcl index 20ed7a0..e11fce1 100644 --- a/library/http/cookiejar.tcl +++ b/library/http/cookiejar.tcl @@ -1,52 +1,97 @@ -package require Tcl 8.5 -package require TclOO -package require http 2.7;#2.8.4 +# Cookie Jar package. + +# Dependencies +package require Tcl 8.5;# FIXME: JUST DURING DEVELOPMENT +package require TclOO;# FIXME: JUST DURING DEVELOPMENT +package require http 2.7;# FIXME: JUST DURING DEVELOPMENT +#package require Tcl 8.6 +#package require http 2.8.4 package require sqlite3 +# Configuration for the cookiejar package namespace eval ::http { # TODO: is this the _right_ list of domains to use? variable cookiejar_domainlist \ http://mxr.mozilla.org/mozilla-central/source/netwerk/dns/effective_tld_names.dat?raw=1 variable cookiejar_version 0.1 variable cookiejar_loglevel info -} + variable cookiejar_vacuumtrigger 200 + + # This is the class that we are creating + ::oo::class create cookiejar -::oo::class create ::http::cookiejar { - self { - method log {origin level msg} { + # Some support procedures, none particularly useful in general + namespace eval cookiejar_support { + namespace export * + proc locn {secure domain path {key ""}} { + if {$key eq ""} { + format "%s://%s%s" [expr {$secure?"https":"http"}] $domain $path + } else { + format "%s://%s%s?%s" \ + [expr {$secure?"https":"http"}] $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} { upvar 0 ::http::cookiejar_loglevel loglevel + set who [uplevel 1 self] set map {debug 0 info 1 warn 2 error 3} if {[string map $map $level] >= [string map $map $loglevel]} { - set ms [clock milliseconds] - set ts [expr {$ms / 1000}] - set ms [format %03d [expr {$ms % 1000}]] - set t [clock format $ts -format "%Y%m%dT%H%M%S.${ms}Z" -gmt 1] - ::http::Log ${t}:[string toupper $level]:cookiejar($origin):${msg} + ::http::Log "[isoNow] [string toupper $level] cookiejar($who) - ${msg}" } } - method loglevel {{level "\u0000\u0000"}} { - upvar 0 ::http::cookiejar_loglevel loglevel - if {$level in {debug info warn error}} { - set loglevel $level - } elseif {$level ne "\u0000\u0000"} { - return -code error "unknown log level \"$level\": must be debug, info, warn, or error" - } - return $loglevel + } +} + +# Now we have enough information to provide the package. +package provide cookiejar $::http::cookiejar_version + +# The implementation of the cookiejar package +::oo::define ::http::cookiejar { + self method loglevel {{level "\u0000\u0000"}} { + upvar 0 ::http::cookiejar_loglevel loglevel + if {$level in {debug info warn error}} { + set loglevel $level + } elseif {$level ne "\u0000\u0000"} { + return -code error "unknown log level \"$level\": must be debug, info, warn, or error" } + return $loglevel } variable aid deletions constructor {{path ""}} { + namespace import ::http::cookiejar_support::* + if {$path eq ""} { sqlite3 [namespace current]::db :memory: } else { sqlite3 [namespace current]::db $path db timeout 500 } - proc log {level msg} \ - "::http::cookiejar log [list [self]] \$level \$msg" + set deletions 0 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, @@ -58,12 +103,14 @@ namespace eval ::http { expiry INTEGER NOT NULL, creation INTEGER NOT NULL); CREATE UNIQUE INDEX IF NOT EXISTS persistentUnique - ON persistentCookies (domain, path, key); + ON persistentCookies (domain, path, key); CREATE INDEX IF NOT EXISTS persistentLookup - ON persistentCookies (domain, path); - } - ## TODO: Are there "TEMP INDEX"es? - db eval { + 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, @@ -75,10 +122,19 @@ namespace eval ::http { lastuse INTEGER NOT NULL, creation INTEGER NOT NULL); CREATE UNIQUE INDEX sessionUnique - ON sessionCookies (domain, path, key); + ON sessionCookies (domain, path, key); CREATE INDEX sessionLookup ON sessionCookies (domain, path); + + --;# View to allow for simple looking up of a cookie. + CREATE TEMP VIEW cookies AS + SELECT id, domain, path, key, value, originonly, secure, + 1 AS persistent + FROM persistentCookies + UNION + SELECT id, domain, path, key, value, originonly, secure, + 0 AS persistent + FROM sessionCookies; } - ## TODO: Consider creating a view db eval { SELECT COUNT(*) AS cookieCount FROM persistentCookies @@ -91,10 +147,17 @@ namespace eval ::http { # TODO: domain list refresh policy db eval { + --;# Domains that may not have a cookie defined for them. CREATE TABLE IF NOT EXISTS forbidden ( domain TEXT PRIMARY KEY); + + --;# Domains that may not have a cookie defined for direct child + --;# domains of them. CREATE TABLE IF NOT EXISTS forbiddenSuper ( domain TEXT PRIMARY KEY); + + --;# Domains that *may* have a cookie defined for them, used to + --;# define exceptions for the forbiddenSuper table. CREATE TABLE IF NOT EXISTS permitted ( domain TEXT PRIMARY KEY); } @@ -155,18 +218,9 @@ namespace eval ::http { db close } - method RenderLocation {secure domain path {key ""}} { - if {$key eq ""} { - format "%s://%s%s" [expr {$secure?"https":"http"}] $domain $path - } else { - format "%s://%s%s?%s" \ - [expr {$secure?"https":"http"}] $domain $path $key - } - } - method GetCookiesForHostAndPath {listVar secure host path fullhost} { upvar 1 $listVar result - log debug "check for cookies for [my RenderLocation $secure $host $path]" + log debug "check for cookies for [locn $secure $host $path]" db eval { SELECT key, value FROM persistentCookies WHERE domain = $host AND path = $path AND secure <= $secure @@ -181,35 +235,19 @@ namespace eval ::http { AND (NOT originonly OR domain = $fullhost) } { lappend result $key $value - ## FIXME: check syntax! db eval { UPDATE sessionCookies SET lastuse = $now WHERE id = $id } } } - method SplitDomain domain { - set pieces [split $domain "."] - for {set i [llength $pieces]} {[incr i -1] >= 0} {} { - lappend result [join [lrange $pieces $i end] "."] - } - return $result - } - method 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 - } - method getCookies {proto host path} { set result {} - set paths [my SplitPath $path] - set domains [my SplitDomain $host] + set paths [splitPath $path] + set domains [splitDomain $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) + # engine (if that's where they *should* be). # Suggestion from kbk: #LENGTH(theColumn) <= LENGTH($queryStr) AND SUBSTR(theColumn, LENGTH($queryStr) LENGTH(theColumn)+1) = $queryStr if {[regexp {[^0-9.]} $host]} { @@ -266,22 +304,6 @@ namespace eval ::http { return 0 } - method DeleteCookie {secure domain path key} { - db eval { - DELETE FROM persistentCookies - 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 = $key - AND secure <= $secure - } - incr deletions [incr del [db changes]] - log debug "deleted $del cookies for [my RenderLocation $secure $domain $path $key]" - } - method storeCookie {name val options} { set now [clock seconds] db transaction { @@ -291,32 +313,45 @@ namespace eval ::http { set now [clock seconds] dict with options {} if {!$persistent} { - ### FIXME db eval { INSERT OR REPLACE INTO sessionCookies ( - secure, domain, path, key, value, originonly, creation) - VALUES ($secure, $domain, $path, $key, $value, $hostonly, $now); + secure, domain, path, key, value, originonly, creation, lastuse) + VALUES ($secure, $domain, $path, $key, $value, $hostonly, $now, $now); DELETE FROM persistentCookies - WHERE secure <= $secure AND domain = $domain AND path = $path AND key = $key + WHERE domain = $domain AND path = $path AND key = $key AND secure <= $secure } - log debug "defined session cookie for [my RenderLocation $secure $domain $path $key]" + incr deletions [db changes] + log debug "defined session cookie for [locn $secure $domain $path $key]" } elseif {$expires < $now} { - my DeleteCookie $secure $domain $path $key + db eval { + DELETE FROM persistentCookies + 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 = $key + AND secure <= $secure; + } + incr deletions [incr del [db changes]] + log debug "deleted $del cookies for [locn $secure $domain $path $key]" } else { - ### FIXME db eval { INSERT OR REPLACE INTO persistentCookies ( secure, domain, path, key, value, originonly, expiry, creation) VALUES ($secure, $domain, $path, $key, $value, $hostonly, $expires, $now); DELETE FROM sessionCookies - WHERE secure <= $secure AND domain = $domain AND path = $path AND key = $key + WHERE domain = $domain AND path = $path AND key = $key AND secure <= $secure } - log debug "defined persistent cookie for [my RenderLocation $secure $host $path $key], expires at [clock format $expires]" + incr deletions [db changes] + log debug "defined persistent cookie for [locn $secure $domain $path $key], expires at [clock format $expires]" } } } method PurgeCookies {} { + upvar 0 ::http::cookiejar_vacuumtrigger vacuumtrigger set aid [after 60000 [namespace current]::my PurgeCookies] set now [clock seconds] log debug "purging cookies that expired before [clock format $now]" @@ -325,19 +360,22 @@ namespace eval ::http { DELETE FROM persistentCookies WHERE expiry < $now } incr deletions [db changes] - if {$deletions > 100} { - set deletions 0 - log debug "vacuuming cookie database" + } + ### TODO: Cap the total number of cookies and session cookies, + ### purging least frequently used + + # Once we've deleted a fair bit, vacuum the database. Must be done + # outside a transaction. + if {$deletions > $vacuumtrigger} { + set deletions 0 + log debug "vacuuming cookie database" + catch { db eval { VACUUM } } } - ### TODO: Cap the total number of cookies and session cookies, - ### purging least frequently used } forward Database db } - -package provide cookiejar $::http::cookiejar_version -- cgit v0.12 From ef405dbe9cd32dfc4294ae138d66bbac63172a4b Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 9 Sep 2012 12:02:38 +0000 Subject: working on handling punycoding of IDNAs --- library/http/cookiejar.tcl | 290 ++++++++++++++++++++++++++++++++++++++++----- 1 file changed, 261 insertions(+), 29 deletions(-) diff --git a/library/http/cookiejar.tcl b/library/http/cookiejar.tcl index e11fce1..605a621 100644 --- a/library/http/cookiejar.tcl +++ b/library/http/cookiejar.tcl @@ -13,6 +13,7 @@ namespace eval ::http { # TODO: is this the _right_ list of domains to use? variable cookiejar_domainlist \ http://mxr.mozilla.org/mozilla-central/source/netwerk/dns/effective_tld_names.dat?raw=1 + # The list is directed to from http://publicsuffix.org/list/ variable cookiejar_version 0.1 variable cookiejar_loglevel info variable cookiejar_vacuumtrigger 200 @@ -59,6 +60,17 @@ namespace eval ::http { ::http::Log "[isoNow] [string toupper $level] cookiejar($who) - ${msg}" } } + proc IDNAencode str { + set parts {} + # Split term from RFC 3490, Sec 3.1 + foreach part [split $str "\u002E\u3002\uFF0E\uFF61"] { + if {![string is ascii $part]} { + set part xn--[puny::encode $part] + } + lappend parts $part + } + return [join $parts .] + } } } @@ -147,26 +159,25 @@ package provide cookiejar $::http::cookiejar_version # TODO: domain list refresh policy db eval { - --;# Domains that may not have a cookie defined for them. - CREATE TABLE IF NOT EXISTS forbidden ( - domain TEXT PRIMARY KEY); + --;# 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). + 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. CREATE TABLE IF NOT EXISTS forbiddenSuper ( domain TEXT PRIMARY KEY); - - --;# Domains that *may* have a cookie defined for them, used to - --;# define exceptions for the forbiddenSuper table. - CREATE TABLE IF NOT EXISTS permitted ( - domain TEXT PRIMARY KEY); } if {$path ne ""} { if {![db exists { SELECT 1 FROM sqlite_master - WHERE type='table' AND name='forbidden' + WHERE type='table' AND name='domains' }] && ![db exists { - SELECT 1 FROM forbidden + SELECT 1 FROM domains }]} then { my InitDomainList } @@ -186,21 +197,29 @@ package provide cookiejar $::http::cookiejar_version if {[string match //* $line]} continue if {[string match !* $line]} { set line [string range $line 1 end] + set idna [IDNAencode $line] db eval { - INSERT INTO permitted (domain) - VALUES ($line) + INSERT INTO domains (domain, forbidden) + VALUES ($line, 0); + INSERT OR REPLACE INTO domains (domain, forbidden) + VALUES ($idna, 0); } } else { if {[string match {\*.*} $line]} { set line [string range $line 2 end] db eval { INSERT INTO forbiddenSuper (domain) - VALUES ($line) + VALUES ($line); + INSERT OR REPLACE INTO forbiddenSuper (domain) + VALUES ($idna); } } + set idna [IDNAencode $line] db eval { - INSERT INTO forbidden (domain) - VALUES ($line) + INSERT INTO domains (domain, forbidden) + VALUES ($line, 1); + INSERT OR REPLACE INTO domains (domain, forbidden) + VALUES ($idna, 1); } } } @@ -284,22 +303,19 @@ package provide cookiejar $::http::cookiejar_version log warn "bad cookie: for a numeric address" return 1 } - if {[db exists { - SELECT 1 FROM permitted WHERE domain = $domain - }]} {return 0} - if {[db exists { - SELECT 1 FROM forbidden WHERE domain = $domain - }]} { - log warn "bad cookie: for a forbidden address" - return 1 - } - if {[regexp {^[^.]+\.(.+)$} $domain -> super]} { - if {[db exists { - SELECT 1 FROM forbiddenSuper WHERE domain = $super - }]} { + db eval { + SELECT forbidden FROM domains WHERE domain = $domain + } { + if {$forbidden} { log warn "bad cookie: for a forbidden address" - return 1 } + 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 } @@ -379,3 +395,219 @@ package provide cookiejar $::http::cookiejar_version forward Database db } + +# The implementation of the puncode encoder. This is based on the code on +# http://wiki.tcl.tk/10501 but with extensive modifications to be faster when +# encoding. + +# TODO: This gets some strings wrong! + +namespace eval ::http::cookiejar_support::puny { + namespace export encode decode + + variable digits [split "abcdefghijklmnopqrstuvwxyz0123456789" ""] + + # 3.2 Insertion unsort coding + proc insertionUnsort {splitstr extended} { + set oldchar 128 + set result {} + set oldindex -1 + foreach c $extended { + set index -1 + set pos -1 + set curlen 0 + foreach c2 $splitstr { + incr curlen [expr {$c2 < $c}] + } + scan $c "%c" char + set delta [expr {($curlen + 1) * ($char - $oldchar)}] + while true { + for {} {[incr pos] < [llength $splitstr]} {} { + set c2 [lindex $splitstr $pos] + if {$c2 eq $c} { + incr index + break + } elseif {$c2 < $c} { + incr index + } + } + if {$pos == [llength $splitstr]} { + set pos -1 + break + } + lappend result [expr {$delta + $index - $oldindex - 1}] + set oldindex $index + set delta 0 + } + set oldchar $char + } + return $result + } + + # Punycode parameters: tmin = 1, tmax = 26, base = 36 + proc T {j bias} { + return [expr {min(max(36 * ($j + 1) - $bias, 1), 26)}] + } + + # 3.3 Generalized variable-length integers + proc generateGeneralizedInteger {N bias} { + variable digits + set result {} + set j 0 + while true { + set t [T $j $bias] + if {$N < $t} { + return [lappend result [lindex $digits $N]] + } + lappend result [lindex $digits [expr {$t + (($N-$t) % (36-$t))}]] + set N [expr {int(($N-$t) / (36-$t))}] + incr j + } + } + + proc adapt {delta first numchars} { + if {$first} { + set delta [expr {int($delta / 700)}] + } else { + set delta [expr {int($delta / 2)}] + } + incr delta [expr {int($delta / $numchars)}] + set divisions 0 + while {$delta > 455} { + set delta [expr {int($delta / 35)}] + incr divisions 36 + } + return [expr {$divisions + int(36 * $delta / ($delta + 38))}] + } + + proc encode {text} { + set base {} + set extenders {} + set splitstr [split $text ""] + foreach c $splitstr { + if {$c < "\u0080"} { + append base $c + } else { + lappend extenders $c + } + } + set deltas [insertionUnsort $splitstr [lsort $extenders]] + + set result {} + set bias 72 + set points 0 + if {$base ne ""} { + set baselen [string length $base] + foreach delta $deltas { + lappend result {*}[generateGeneralizedInteger $delta $bias] + set bias [adapt $delta [expr {!$points}] \ + [expr {$baselen + [incr points]}]] + } + return $base-[join $result ""] + } else { + foreach delta $deltas { + lappend result {*}[generateGeneralizedInteger $delta $bias] + set bias [adapt $delta [expr {!$points}] [incr points]] + } + return [join $result ""] + } + } + + + # Decoding + proc toNums {text} { + set retval {} + foreach c [split $text ""] { + scan $c "%c" ch + lappend retval $ch + } + return $retval + } + + proc toChars {nums} { + set chars {} + foreach char $nums { + append chars [format "%c" $char] + } + return $chars + } + + # 3.3 Generalized variable-length integers + proc decodeGeneralizedNumber {extended extpos bias errors} { + set result 0 + set w 1 + set j 0 + while true { + set c [lindex $extended $extpos] + incr extpos + if {[string length $c] == 0} { + if {$errors eq "strict"} { + error "incomplete punicode string" + } + return [list $extpos -1] + } + if {[string match {[A-Z]} $c]} { + scan $c "%c" char + set digit [expr {$char - 65}] + } elseif {[string match {[0-9]} $c]} { + scan $c "%c" char + # 0x30-26 + set digit [expr {$char - 22}] + } elseif {$errors eq "strict"} { + set pos [lindex $extended $extpos] + error "Invalid extended code point '$pos'" + } else { + return [list $extpos -1] + } + set t [T $j $bias] + set result [expr {$result + $digit * $w}] + if {$digit < $t} { + return [list $extpos $result] + } + set w [expr {$w * (36 - $t)}] + incr j + } + } + + # 3.2 Insertion unsort coding + proc insertionSort {base extended errors} { + set char 128 + set pos -1 + set bias 72 + set extpos 0 + while {$extpos < [llength $extended]} { + lassign [decodeGeneralizedNumber $extended $extpos $bias $errors]\ + newpos delta + if {$delta < 0} { + # There was an error in decoding. We can't continue because + # synchronization is lost. + return $base + } + set pos [expr {$pos + $delta + 1}] + set char [expr {$char + int($pos / ([llength $base] + 1))}] + if {$char > 1114111} { + if {$errors eq "strict"} { + error [format "Invalid character U+%x" $char] + } + set char 63 ;# "?" + } + set pos [expr {$pos % ([llength $base] + 1)}] + set base [linsert $base $pos $char] + set bias [adapt $delta [expr {$extpos == 0}] [llength $base]] + set extpos $newpos + } + return $base + } + + proc decode {text {errors "lax"}} { + set base {} + set pos [string last "-" $text] + if {$pos == -1} { + set extended [split [string toupper $text] ""] + } else { + set base [toNums [string range $text 0 [expr {$pos-1}]]] + set extended [split [string toupper [string range $text [expr {$pos+1}] end]] ""] + } + return [toChars [insertionSort $base $extended $errors]] + } +} -- cgit v0.12 From 99359a48d9f24edccccf5deb2745b83fc6f278d9 Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 10 Sep 2012 11:00:59 +0000 Subject: Now, a working punycode engine --- library/http/cookiejar.tcl | 255 ++++++++++++++++++++++++--------------------- 1 file changed, 137 insertions(+), 118 deletions(-) diff --git a/library/http/cookiejar.tcl b/library/http/cookiejar.tcl index 605a621..ad56e31 100644 --- a/library/http/cookiejar.tcl +++ b/library/http/cookiejar.tcl @@ -397,120 +397,132 @@ package provide cookiejar $::http::cookiejar_version } # The implementation of the puncode encoder. This is based on the code on -# http://wiki.tcl.tk/10501 but with extensive modifications to be faster when -# encoding. - -# TODO: This gets some strings wrong! +# http://tools.ietf.org/html/rfc3492 (encoder) and http://wiki.tcl.tk/10501 +# (decoder) but with extensive modifications. namespace eval ::http::cookiejar_support::puny { namespace export encode decode 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 - # 3.2 Insertion unsort coding - proc insertionUnsort {splitstr extended} { - set oldchar 128 - set result {} - set oldindex -1 - foreach c $extended { - set index -1 - set pos -1 - set curlen 0 - foreach c2 $splitstr { - incr curlen [expr {$c2 < $c}] - } - scan $c "%c" char - set delta [expr {($curlen + 1) * ($char - $oldchar)}] - while true { - for {} {[incr pos] < [llength $splitstr]} {} { - set c2 [lindex $splitstr $pos] - if {$c2 eq $c} { - incr index - break - } elseif {$c2 < $c} { - incr index + 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 encode function + proc encode {input {case ""}} { + variable digits + variable tmin + variable tmax + variable base + variable initial_n + variable initial_bias + + set in [split $input ""] + set output {} + + # Initialize the state: + set n $initial_n + set delta 0 + set bias $initial_bias + + # Handle the basic code points: + foreach ch $in { + if {$ch < "\u0080"} { + if {$case ne ""} { + if {$case} { + append output [string toupper $ch] + } else { + append output [string tolower $ch] } + } else { + append output $ch } - if {$pos == [llength $splitstr]} { - set pos -1 - break - } - lappend result [expr {$delta + $index - $oldindex - 1}] - set oldindex $index - set delta 0 } - set oldchar $char } - return $result - } - # Punycode parameters: tmin = 1, tmax = 26, base = 36 - proc T {j bias} { - return [expr {min(max(36 * ($j + 1) - $bias, 1), 26)}] - } + set h [set b [string length $output]] - # 3.3 Generalized variable-length integers - proc generateGeneralizedInteger {N bias} { - variable digits - set result {} - set j 0 - while true { - set t [T $j $bias] - if {$N < $t} { - return [lappend result [lindex $digits $N]] - } - lappend result [lindex $digits [expr {$t + (($N-$t) % (36-$t))}]] - set N [expr {int(($N-$t) / (36-$t))}] - incr j - } - } + # h is the number of code points that have been handled, b is the + # number of basic code points. - proc adapt {delta first numchars} { - if {$first} { - set delta [expr {int($delta / 700)}] - } else { - set delta [expr {int($delta / 2)}] - } - incr delta [expr {int($delta / $numchars)}] - set divisions 0 - while {$delta > 455} { - set delta [expr {int($delta / 35)}] - incr divisions 36 + if {$b} { + append output "-" } - return [expr {$divisions + int(36 * $delta / ($delta + 38))}] - } - proc encode {text} { - set base {} - set extenders {} - set splitstr [split $text ""] - foreach c $splitstr { - if {$c < "\u0080"} { - append base $c - } else { - lappend extenders $c + # Main encoding loop: + + while {$h < [llength $in]} { + # All non-basic code points < n have been handled already. Find + # the next larger one: + + for {set m inf; set j 0} {$j < [llength $in]} {incr j} { + scan [lindex $in $j] "%c" ch + if {$ch >= $n && $ch < $m} { + set m $ch + } } - } - set deltas [insertionUnsort $splitstr [lsort $extenders]] - set result {} - set bias 72 - set points 0 - if {$base ne ""} { - set baselen [string length $base] - foreach delta $deltas { - lappend result {*}[generateGeneralizedInteger $delta $bias] - set bias [adapt $delta [expr {!$points}] \ - [expr {$baselen + [incr points]}]] + # 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" } - return $base-[join $result ""] - } else { - foreach delta $deltas { - lappend result {*}[generateGeneralizedInteger $delta $bias] - set bias [adapt $delta [expr {!$points}] [incr points]] + incr delta [expr {($m-$n) * ($h+1)}] + set n $m + + for {set j 0} {$j < [llength $in]} {incr j} { + scan [lindex $in $j] "%c" ch + if {$ch < $n && ([incr delta] & 0xffffffff) == 0} { + throw {PUNYCODE OVERFLOW} "overflow in delta computation" + } + + if {$ch == $n} { + # 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 [join $result ""] + + incr delta + incr n } + + return $output } @@ -533,7 +545,11 @@ namespace eval ::http::cookiejar_support::puny { } # 3.3 Generalized variable-length integers - proc decodeGeneralizedNumber {extended extpos bias errors} { + proc decodeGeneralizedInteger {extended extpos bias errors} { + variable tmin + variable tmax + variable base + set result 0 set w 1 set j 0 @@ -546,68 +562,71 @@ namespace eval ::http::cookiejar_support::puny { } return [list $extpos -1] } + scan $c "%c" char if {[string match {[A-Z]} $c]} { - scan $c "%c" char - set digit [expr {$char - 65}] + set digit [expr {$char - 0x41}]; # A=0,Z=25 + } elseif {[string match {[a-z]} $c]} { + set digit [expr {$char - 0x61}]; # a=0,z=25 } elseif {[string match {[0-9]} $c]} { - scan $c "%c" char - # 0x30-26 - set digit [expr {$char - 22}] + set digit [expr {$char - 0x30 + 26}]; # 0=26,9=35 } elseif {$errors eq "strict"} { set pos [lindex $extended $extpos] error "Invalid extended code point '$pos'" } else { return [list $extpos -1] } - set t [T $j $bias] + set t [expr {min(max($base*($j + 1) - $bias, $tmin), $tmax)}] set result [expr {$result + $digit * $w}] if {$digit < $t} { return [list $extpos $result] } - set w [expr {$w * (36 - $t)}] + set w [expr {$w * ($base - $t)}] incr j } } # 3.2 Insertion unsort coding - proc insertionSort {base extended errors} { - set char 128 + proc insertionSort {buffer extended errors} { + variable initial_bias + variable initial_n + + set char $initial_n set pos -1 - set bias 72 + set bias $initial_bias set extpos 0 while {$extpos < [llength $extended]} { - lassign [decodeGeneralizedNumber $extended $extpos $bias $errors]\ + lassign [decodeGeneralizedInteger $extended $extpos $bias $errors]\ newpos delta if {$delta < 0} { # There was an error in decoding. We can't continue because # synchronization is lost. - return $base + return $buffer } - set pos [expr {$pos + $delta + 1}] - set char [expr {$char + int($pos / ([llength $base] + 1))}] + incr pos [expr {$delta + 1}] + set char [expr {$char + $pos / ([llength $buffer] + 1)}] if {$char > 1114111} { if {$errors eq "strict"} { error [format "Invalid character U+%x" $char] } set char 63 ;# "?" } - set pos [expr {$pos % ([llength $base] + 1)}] - set base [linsert $base $pos $char] - set bias [adapt $delta [expr {$extpos == 0}] [llength $base]] + set pos [expr {$pos % ([llength $buffer] + 1)}] + set buffer [linsert $buffer $pos $char] + set bias [adapt $delta [expr {$extpos == 0}] [llength $buffer]] set extpos $newpos } - return $base + return $buffer } proc decode {text {errors "lax"}} { - set base {} + set baseline {} set pos [string last "-" $text] if {$pos == -1} { - set extended [split [string toupper $text] ""] + set extended $text } else { - set base [toNums [string range $text 0 [expr {$pos-1}]]] - set extended [split [string toupper [string range $text [expr {$pos+1}] end]] ""] + set baseline [toNums [string range $text 0 [expr {$pos-1}]]] + set extended [string range $text [expr {$pos+1}] end] } - return [toChars [insertionSort $base $extended $errors]] + return [toChars [insertionSort $baseline [split $extended ""] $errors]] } } -- cgit v0.12 From 6f1a0f1c60d7c85d2e331d67a431a9306bab8c48 Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 10 Sep 2012 21:24:34 +0000 Subject: loading of restricted domain list now believed to work --- library/http/cookiejar.tcl | 171 ++++++++++++++++++++------------ library/http/effective_tld_names.txt.gz | Bin 0 -> 32891 bytes 2 files changed, 110 insertions(+), 61 deletions(-) create mode 100644 library/http/effective_tld_names.txt.gz diff --git a/library/http/cookiejar.tcl b/library/http/cookiejar.tcl index ad56e31..be7b37f 100644 --- a/library/http/cookiejar.tcl +++ b/library/http/cookiejar.tcl @@ -7,16 +7,20 @@ package require http 2.7;# FIXME: JUST DURING DEVELOPMENT #package require Tcl 8.6 #package require http 2.8.4 package require sqlite3 +#package require zlib # Configuration for the cookiejar package namespace eval ::http { # TODO: is this the _right_ list of domains to use? variable cookiejar_domainlist \ http://mxr.mozilla.org/mozilla-central/source/netwerk/dns/effective_tld_names.dat?raw=1 + variable cookiejar_domainfile \ + [file join [file dirname [info script]] effective_tld_names.txt] # The list is directed to from http://publicsuffix.org/list/ variable cookiejar_version 0.1 variable cookiejar_loglevel info variable cookiejar_vacuumtrigger 200 + variable cookiejar_offline false # This is the class that we are creating ::oo::class create cookiejar @@ -53,7 +57,7 @@ namespace eval ::http { clock format $ts -format "%Y%m%dT%H%M%S.${ms}Z" -gmt 1 } proc log {level msg} { - upvar 0 ::http::cookiejar_loglevel loglevel + namespace upvar ::http cookiejar_loglevel loglevel set who [uplevel 1 self] set map {debug 0 info 1 warn 2 error 3} if {[string map $map $level] >= [string map $map $loglevel]} { @@ -71,6 +75,17 @@ namespace eval ::http { } return [join $parts .] } + proc IDNAdecode str { + set parts {} + # Split term from RFC 3490, Sec 3.1 + foreach part [split $str "\u002E\u3002\uFF0E\uFF61"] { + if {[string match "xn--*" $part]} { + set part [puny::decode [string range $part 4 end]] + } + lappend parts $part + } + return [join $parts .] + } } } @@ -80,7 +95,7 @@ package provide cookiejar $::http::cookiejar_version # The implementation of the cookiejar package ::oo::define ::http::cookiejar { self method loglevel {{level "\u0000\u0000"}} { - upvar 0 ::http::cookiejar_loglevel loglevel + namespace upvar ::http cookiejar_loglevel loglevel if {$level in {debug info warn error}} { set loglevel $level } elseif {$level ne "\u0000\u0000"} { @@ -165,70 +180,105 @@ package provide cookiejar $::http::cookiejar_version --;# forbiddenSuper table). CREATE TABLE IF NOT EXISTS domains ( domain TEXT PRIMARY KEY NOT NULL, - forbidden INTEGER NOT NULL) + forbidden INTEGER NOT NULL); --;# Domains that may not have a cookie defined for direct child --;# domains of them. CREATE TABLE IF NOT EXISTS forbiddenSuper ( domain TEXT PRIMARY KEY); } - if {$path ne ""} { - if {![db exists { - SELECT 1 FROM sqlite_master - WHERE type='table' AND name='domains' - }] && ![db exists { - SELECT 1 FROM domains - }]} then { - my InitDomainList - } + if {$path ne "" && ![db exists { + SELECT 1 FROM domains + }]} then { + my InitDomainList } } method InitDomainList {} { - # TODO: Handle IDNs (but Tcl overall gets that wrong at the moment...) - variable ::http::cookiejar_domainlist - log debug "loading domain list from $cookiejar_domainlist" - set tok [http::geturl $cookiejar_domainlist] + namespace upvar ::http \ + cookiejar_domainlist url \ + cookiejar_domainfile filename \ + cookiejar_offline offline + if {!$offline} { + log debug "loading domain list from $url" + set tok [::http::geturl $url] + try { + if {[::http::ncode $tok] == 200} { + my InstallDomainData [::http::data $tok] + return + } else { + log error "failed to fetch list of forbidden cookie domains from ${url}: [::http::error $tok]" + log warn "attempting to fall back to built in version" + } + } finally { + ::http::cleanup $tok + } + } + log debug "loading domain list from $filename" try { - if {[http::ncode $tok] == 200} { - db transaction { - foreach line [split [http::data $tok] \n] { - if {[string trim $line] eq ""} continue - if {[string match //* $line]} continue - if {[string match !* $line]} { - set line [string range $line 1 end] - set idna [IDNAencode $line] - db eval { - INSERT INTO domains (domain, forbidden) - VALUES ($line, 0); - INSERT OR REPLACE INTO domains (domain, forbidden) - VALUES ($idna, 0); - } - } else { - if {[string match {\*.*} $line]} { - set line [string range $line 2 end] - db eval { - INSERT INTO forbiddenSuper (domain) - VALUES ($line); - INSERT OR REPLACE INTO forbiddenSuper (domain) - VALUES ($idna); - } - } - set idna [IDNAencode $line] - db eval { - INSERT INTO domains (domain, forbidden) - VALUES ($line, 1); - INSERT OR REPLACE INTO domains (domain, forbidden) - VALUES ($idna, 1); - } + set f [open $filename] + try { + if {[string match *.gz $filename]} { + zlib push gunzip $f + } + fconfigure $f -encoding utf-8 + my InstallDomainData [read $f] + } finally { + close $f + } + } on error msg { + log error "failed to read list of forbidden cookie domains from ${filename}: $msg" + return -code error $msg + } + } + + method InstallDomainData {data} { + set n [db total_changes] + db transaction { + foreach line [split $data "\n"] { + if {[string trim $line] eq ""} continue + if {[string match //* $line]} continue + if {[string match !* $line]} { + set line [string range $line 1 end] + set idna [IDNAencode $line] + db eval { + INSERT INTO domains (domain, forbidden) + VALUES ($line, 0); + INSERT OR REPLACE INTO domains (domain, forbidden) + VALUES ($idna, 0); + } + } else { + if {[string match {\*.*} $line]} { + set line [string range $line 2 end] + db eval { + INSERT INTO forbiddenSuper (domain) + VALUES ($line); + INSERT OR REPLACE INTO forbiddenSuper (domain) + VALUES ($idna); } } + set idna [IDNAencode $line] + db eval { + INSERT INTO domains (domain, forbidden) + VALUES ($line, 1); + INSERT OR REPLACE INTO domains (domain, forbidden) + VALUES ($idna, 1); + } } - } else { - log error "failed to fetch list of forbidden cookie domains from $cookiejar_domainlist" } - } finally { - http::cleanup $tok + } + set n [expr {[db total_changes] - $n}] + log debug "processed $n inserts generated from domain list" + } + + # This forces the rebuild of the domain data, loading it from + method forceLoadDomainData {} { + db transaction { + db eval { + DELETE FROM domains; + DELETE FROM forbiddenSuper; + } + my InitDomainList } } @@ -367,7 +417,7 @@ package provide cookiejar $::http::cookiejar_version } method PurgeCookies {} { - upvar 0 ::http::cookiejar_vacuumtrigger vacuumtrigger + namespace upvar 0 ::http cookiejar_vacuumtrigger vacuumtrigger set aid [after 60000 [namespace current]::my PurgeCookies] set now [clock seconds] log debug "purging cookies that expired before [clock format $now]" @@ -488,7 +538,7 @@ namespace eval ::http::cookiejar_support::puny { # , but guard against overflow: if {$m-$n > (0xffffffff-$delta)/($h+1)} { - throw {PUNYCODE OVERFLOW} "overflow in delta computation" + error "overflow in delta computation" } incr delta [expr {($m-$n) * ($h+1)}] set n $m @@ -496,7 +546,7 @@ namespace eval ::http::cookiejar_support::puny { for {set j 0} {$j < [llength $in]} {incr j} { scan [lindex $in $j] "%c" ch if {$ch < $n && ([incr delta] & 0xffffffff) == 0} { - throw {PUNYCODE OVERFLOW} "overflow in delta computation" + error "overflow in delta computation" } if {$ch == $n} { @@ -525,7 +575,6 @@ namespace eval ::http::cookiejar_support::puny { return $output } - # Decoding proc toNums {text} { set retval {} @@ -590,7 +639,7 @@ namespace eval ::http::cookiejar_support::puny { variable initial_bias variable initial_n - set char $initial_n + set n $initial_n set pos -1 set bias $initial_bias set extpos 0 @@ -603,15 +652,15 @@ namespace eval ::http::cookiejar_support::puny { return $buffer } incr pos [expr {$delta + 1}] - set char [expr {$char + $pos / ([llength $buffer] + 1)}] - if {$char > 1114111} { + incr n [expr {$pos / ([llength $buffer] + 1)}] + if {$n > 1114111} { if {$errors eq "strict"} { - error [format "Invalid character U+%x" $char] + error [format "Invalid character U+%06x" $n] } - set char 63 ;# "?" + set n 63 ;# "?" } set pos [expr {$pos % ([llength $buffer] + 1)}] - set buffer [linsert $buffer $pos $char] + set buffer [linsert $buffer $pos $n] set bias [adapt $delta [expr {$extpos == 0}] [llength $buffer]] set extpos $newpos } diff --git a/library/http/effective_tld_names.txt.gz b/library/http/effective_tld_names.txt.gz new file mode 100644 index 0000000..a799d16 Binary files /dev/null and b/library/http/effective_tld_names.txt.gz differ -- cgit v0.12 From 52d39094e48a6c1b184d207d1e191266eaf1e0d0 Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 11 Sep 2012 10:37:10 +0000 Subject: packing the code tighter, doing more explanatory comments --- library/http/cookiejar.tcl | 384 ++++++++++++++++++++++++++------------------- 1 file changed, 222 insertions(+), 162 deletions(-) diff --git a/library/http/cookiejar.tcl b/library/http/cookiejar.tcl index be7b37f..c1e837c 100644 --- a/library/http/cookiejar.tcl +++ b/library/http/cookiejar.tcl @@ -1,5 +1,12 @@ -# Cookie Jar package. - +# 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.5;# FIXME: JUST DURING DEVELOPMENT package require TclOO;# FIXME: JUST DURING DEVELOPMENT @@ -7,20 +14,26 @@ package require http 2.7;# FIXME: JUST DURING DEVELOPMENT #package require Tcl 8.6 #package require http 2.8.4 package require sqlite3 -#package require zlib + +# +# Configuration for the cookiejar package, plus basic support procedures. +# -# Configuration for the cookiejar package namespace eval ::http { + # Keep this in sync with pkgIndex.tcl and with the install directories in + # Makefiles + variable cookiejar_version 0.1 + # TODO: is this the _right_ list of domains to use? variable cookiejar_domainlist \ http://mxr.mozilla.org/mozilla-central/source/netwerk/dns/effective_tld_names.dat?raw=1 variable cookiejar_domainfile \ [file join [file dirname [info script]] effective_tld_names.txt] # The list is directed to from http://publicsuffix.org/list/ - variable cookiejar_version 0.1 variable cookiejar_loglevel info variable cookiejar_vacuumtrigger 200 variable cookiejar_offline false + variable cookiejar_purgeinterval 60000 # This is the class that we are creating ::oo::class create cookiejar @@ -30,10 +43,12 @@ namespace eval ::http { namespace export * proc locn {secure domain path {key ""}} { if {$key eq ""} { - format "%s://%s%s" [expr {$secure?"https":"http"}] $domain $path + format "%s://%s%s" [expr {$secure?"https":"http"}] \ + [IDNAencode $domain] $path } else { format "%s://%s%s?%s" \ - [expr {$secure?"https":"http"}] $domain $path $key + [expr {$secure?"https":"http"}] [IDNAencode $domain] \ + $path $key } } proc splitDomain domain { @@ -107,6 +122,7 @@ package provide cookiejar $::http::cookiejar_version variable aid deletions constructor {{path ""}} { namespace import ::http::cookiejar_support::* + namespace upvar ::http cookiejar_purgeinterval purgeinterval if {$path eq ""} { sqlite3 [namespace current]::db :memory: @@ -161,32 +177,31 @@ package provide cookiejar $::http::cookiejar_version SELECT id, domain, path, key, value, originonly, secure, 0 AS persistent FROM sessionCookies; - } - - db eval { - SELECT COUNT(*) AS cookieCount FROM persistentCookies - } - if {[info exist cookieCount] && $cookieCount} { - log info "loaded cookie store from $path with $cookieCount entries" - } - set aid [after 60000 [namespace current]::my PurgeCookies] - - # TODO: domain list refresh policy - db eval { --;# 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); } + + db eval { + SELECT COUNT(*) AS cookieCount FROM persistentCookies + } + log info "loaded cookie store from $path with $cookieCount entries" + + set aid [after $purgeinterval [namespace current]::my PurgeCookies] + + # TODO: domain list refresh policy if {$path ne "" && ![db exists { SELECT 1 FROM domains }]} then { @@ -236,35 +251,57 @@ package provide cookiejar $::http::cookiejar_version set n [db total_changes] db transaction { foreach line [split $data "\n"] { - if {[string trim $line] eq ""} continue - if {[string match //* $line]} continue - if {[string match !* $line]} { + if {[string trim $line] eq ""} { + continue + } elseif {[string match //* $line]} { + continue + } elseif {[string match !* $line]} { set line [string range $line 1 end] set idna [IDNAencode $line] + set utf [IDNAdecode $line] db eval { - INSERT INTO domains (domain, forbidden) - VALUES ($line, 0); INSERT OR REPLACE INTO domains (domain, forbidden) - VALUES ($idna, 0); + 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 [IDNAencode $line] + set utf [IDNAdecode $line] db eval { - INSERT INTO forbiddenSuper (domain) - VALUES ($line); INSERT OR REPLACE INTO forbiddenSuper (domain) - VALUES ($idna); + VALUES ($utf); + } + if {$idna ne $utf} { + db eval { + INSERT OR REPLACE INTO forbiddenSuper (domain) + VALUES ($idna); + } } + } else { + set idna [IDNAencode $line] + set utf [IDNAdecode $line] } - set idna [IDNAencode $line] db eval { - INSERT INTO domains (domain, forbidden) - VALUES ($line, 1); INSERT OR REPLACE INTO domains (domain, forbidden) - VALUES ($idna, 1); + VALUES ($utf, 1); + } + if {$idna ne $utf} { + db eval { + INSERT OR REPLACE INTO domains (domain, forbidden) + VALUES ($idna, 1); + } } } + if {$utf ne [IDNAdecode $idna]} { + log warn "mismatch in IDNA handling for $idna" + } } } set n [expr {[db total_changes] - $n}] @@ -313,13 +350,15 @@ package provide cookiejar $::http::cookiejar_version method getCookies {proto host path} { set result {} set paths [splitPath $path] - set domains [splitDomain $host] + set domains [splitDomain [IDNAencode $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 + #LENGTH(theColumn) <= LENGTH($queryStr) AND + #SUBSTR(theColumn, LENGTH($queryStr) LENGTH(theColumn)+1) = $queryStr if {[regexp {[^0-9.]} $host]} { + # Ugh, it's a numeric domain! Restrict it... db transaction { foreach domain $domains { foreach p $paths { @@ -417,8 +456,10 @@ package provide cookiejar $::http::cookiejar_version } method PurgeCookies {} { - namespace upvar 0 ::http cookiejar_vacuumtrigger vacuumtrigger - set aid [after 60000 [namespace current]::my PurgeCookies] + namespace upvar ::http \ + cookiejar_vacuumtrigger trigger \ + cookiejar_purgeinterval interval + set aid [after $interval [namespace current]::my PurgeCookies] set now [clock seconds] log debug "purging cookies that expired before [clock format $now]" db transaction { @@ -432,7 +473,7 @@ package provide cookiejar $::http::cookiejar_version # Once we've deleted a fair bit, vacuum the database. Must be done # outside a transaction. - if {$deletions > $vacuumtrigger} { + if {$deletions > $trigger} { set deletions 0 log debug "vacuuming cookie database" catch { @@ -444,9 +485,44 @@ package provide cookiejar $::http::cookiejar_version } forward Database db + + method lookup {{host ""} {key ""}} { + set host [IDNAencode $host] + db transaction { + if {$host eq ""} { + set result {} + db eval { + SELECT DISTINCT domain FROM cookies + ORDER BY domain + } { + lappend result [IDNAdecode $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" + } + } + } } -# The implementation of the puncode encoder. This is based on the code on +# The implementation of the punycode encoder. This is based on the code on # http://tools.ietf.org/html/rfc3492 (encoder) and http://wiki.tcl.tk/10501 # (decoder) but with extensive modifications. @@ -463,6 +539,10 @@ namespace eval ::http::cookiejar_support::puny { variable initial_bias 72 variable initial_n 0x80 + variable maxcodepoint 0xFFFF ;# 0x10FFFF would be correct, except Tcl + # can't handle non-BMP characters right now + # anyway. + proc adapt {delta first numchars} { variable base variable tmin @@ -489,7 +569,11 @@ namespace eval ::http::cookiejar_support::puny { variable initial_n variable initial_bias - set in [split $input ""] + set in {} + foreach char [set input [split $input ""]] { + scan $char "%c" ch + lappend in $ch + } set output {} # Initialize the state: @@ -498,37 +582,35 @@ namespace eval ::http::cookiejar_support::puny { set bias $initial_bias # Handle the basic code points: - foreach ch $in { + foreach ch $input { if {$ch < "\u0080"} { - if {$case ne ""} { - if {$case} { - append output [string toupper $ch] - } else { - append output [string tolower $ch] - } - } else { + if {$case eq ""} { append output $ch + } elseif {$case} { + append output [string toupper $ch] + } else { + append output [string tolower $ch] } } } - set h [set b [string length $output]] + 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} { + if {$b > 0} { append output "-" } # Main encoding loop: - while {$h < [llength $in]} { + 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: - for {set m inf; set j 0} {$j < [llength $in]} {incr j} { - scan [lindex $in $j] "%c" ch + set m inf + foreach ch $in { if {$ch >= $n && $ch < $m} { set m $ch } @@ -538,144 +620,122 @@ namespace eval ::http::cookiejar_support::puny { # , but guard against overflow: if {$m-$n > (0xffffffff-$delta)/($h+1)} { - error "overflow in delta computation" + throw {PUNYCODE OVERFLOW} "overflow in delta computation" } incr delta [expr {($m-$n) * ($h+1)}] set n $m - for {set j 0} {$j < [llength $in]} {incr j} { - scan [lindex $in $j] "%c" ch + foreach ch $in { if {$ch < $n && ([incr delta] & 0xffffffff) == 0} { - error "overflow in delta computation" + throw {PUNYCODE OVERFLOW} "overflow in delta computation" + } + + if {$ch != $n} { + continue } - if {$ch == $n} { - # Represent delta as a generalized variable-length - # integer: + # 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)}] + 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 $q] - set bias [adapt $delta [expr {$h==$b}] [expr {$h+1}]] - set delta 0 - incr h + append output \ + [lindex $digits [expr {$t + ($q-$t)%($base-$t)}]] + set q [expr {($q-$t) / ($base-$t)}] } - } - incr delta - incr n + append output [lindex $digits $q] + set bias [adapt $delta [expr {$h==$b}] [expr {$h+1}]] + set delta 0 + incr h + } } return $output } - # Decoding - proc toNums {text} { - set retval {} - foreach c [split $text ""] { - scan $c "%c" ch - lappend retval $ch - } - return $retval - } + # Main decode function + proc decode {text {errors "lax"}} { + namespace upvar ::http::cookiejar_support::puny \ + tmin tmin tmax tmax base base initial_bias initial_bias \ + initial_n initial_n maxcodepoint maxcodepoint - proc toChars {nums} { - set chars {} - foreach char $nums { - append chars [format "%c" $char] - } - return $chars - } + set n $initial_n + set pos -1 + set bias $initial_bias + set buffer [set chars {}] + set pos [string last "-" $text] + if {$pos >= 0} { + set buffer [split [string range $text 0 [expr {$pos-1}]] ""] + set text [string range $text [expr {$pos+1}] end] + } + set points [split $text ""] + set first true + + for {set extpos 0} {$extpos < [llength $points]} {} { + # Extract the delta, which is the encoding of the character and + # where to insert it. + + set delta 0 + set w 1 + for {set j 1} true {incr j} { + scan [set c [lindex $points $extpos]] "%c" char + if {[string match {[A-Z]} $c]} { + set digit [expr {$char - 0x41}]; # A=0,Z=25 + } elseif {[string match {[a-z]} $c]} { + set digit [expr {$char - 0x61}]; # a=0,z=25 + } elseif {[string match {[0-9]} $c]} { + set digit [expr {$char - 0x30 + 26}]; # 0=26,9=35 + } else { + if {$errors eq "strict"} { + throw {PUNYCODE INVALID} \ + "invalid extended code point '$c'" + } + # There was an error in decoding. We can't continue + # because synchronization is lost. + return [join $buffer ""] + } - # 3.3 Generalized variable-length integers - proc decodeGeneralizedInteger {extended extpos bias errors} { - variable tmin - variable tmax - variable base + incr extpos + set t [expr {min(max($base*$j - $bias, $tmin), $tmax)}] + incr delta [expr {$digit * $w}] + if {$digit < $t} { + break + } + set w [expr {$w * ($base - $t)}] - set result 0 - set w 1 - set j 0 - while true { - set c [lindex $extended $extpos] - incr extpos - if {[string length $c] == 0} { - if {$errors eq "strict"} { - error "incomplete punicode string" + if {$extpos >= [llength $points]} { + if {$errors eq "strict"} { + throw {PUNYCODE PARTIAL} "incomplete punycode string" + } + # There was an error in decoding. We can't continue + # because synchronization is lost. + return [join $buffer ""] } - return [list $extpos -1] - } - scan $c "%c" char - if {[string match {[A-Z]} $c]} { - set digit [expr {$char - 0x41}]; # A=0,Z=25 - } elseif {[string match {[a-z]} $c]} { - set digit [expr {$char - 0x61}]; # a=0,z=25 - } elseif {[string match {[0-9]} $c]} { - set digit [expr {$char - 0x30 + 26}]; # 0=26,9=35 - } elseif {$errors eq "strict"} { - set pos [lindex $extended $extpos] - error "Invalid extended code point '$pos'" - } else { - return [list $extpos -1] - } - set t [expr {min(max($base*($j + 1) - $bias, $tmin), $tmax)}] - set result [expr {$result + $digit * $w}] - if {$digit < $t} { - return [list $extpos $result] } - set w [expr {$w * ($base - $t)}] - incr j - } - } - # 3.2 Insertion unsort coding - proc insertionSort {buffer extended errors} { - variable initial_bias - variable initial_n + # Now we've got the delta, we can generate the character and + # insert it. - set n $initial_n - set pos -1 - set bias $initial_bias - set extpos 0 - while {$extpos < [llength $extended]} { - lassign [decodeGeneralizedInteger $extended $extpos $bias $errors]\ - newpos delta - if {$delta < 0} { - # There was an error in decoding. We can't continue because - # synchronization is lost. - return $buffer - } - incr pos [expr {$delta + 1}] - incr n [expr {$pos / ([llength $buffer] + 1)}] - if {$n > 1114111} { + incr n [expr {[incr pos [expr {$delta+1}]]/([llength $buffer]+1)}] + if {$n > $maxcodepoint} { if {$errors eq "strict"} { - error [format "Invalid character U+%06x" $n] + if {$n < 0x10ffff} { + throw {PUNYCODE NON_BMP} \ + [format "unsupported character U+%06x" $n] + } + throw {PUNYCODE NON_UNICODE} "bad codepoint $n" } set n 63 ;# "?" + set extpos inf; # We're blowing up anyway... } set pos [expr {$pos % ([llength $buffer] + 1)}] - set buffer [linsert $buffer $pos $n] - set bias [adapt $delta [expr {$extpos == 0}] [llength $buffer]] - set extpos $newpos - } - return $buffer - } - - proc decode {text {errors "lax"}} { - set baseline {} - set pos [string last "-" $text] - if {$pos == -1} { - set extended $text - } else { - set baseline [toNums [string range $text 0 [expr {$pos-1}]]] - set extended [string range $text [expr {$pos+1}] end] + set buffer [linsert $buffer $pos [format "%c" $n]] + set bias [adapt $delta $first [llength $buffer]] + set first false } - return [toChars [insertionSort $baseline [split $extended ""] $errors]] + return [join $buffer ""] } } -- cgit v0.12 From 9bbbadaa5704ec79e853bc99a5ca3288810d4b26 Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 17 Sep 2012 14:44:23 +0000 Subject: adapt to 8.6 environment properly; still some bugs... --- library/http/cookiejar.tcl | 21 ++++++++++++++------- 1 file changed, 14 insertions(+), 7 deletions(-) diff --git a/library/http/cookiejar.tcl b/library/http/cookiejar.tcl index c1e837c..86df72b 100644 --- a/library/http/cookiejar.tcl +++ b/library/http/cookiejar.tcl @@ -8,11 +8,8 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. # Dependencies -package require Tcl 8.5;# FIXME: JUST DURING DEVELOPMENT -package require TclOO;# FIXME: JUST DURING DEVELOPMENT -package require http 2.7;# FIXME: JUST DURING DEVELOPMENT -#package require Tcl 8.6 -#package require http 2.8.4 +package require Tcl 8.6 +package require http 2.8.4 package require sqlite3 # @@ -40,6 +37,13 @@ namespace eval ::http { # Some support procedures, none particularly useful in general namespace eval cookiejar_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 ""} { @@ -126,9 +130,11 @@ package provide cookiejar $::http::cookiejar_version 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 @@ -194,10 +200,11 @@ package provide cookiejar $::http::cookiejar_version domain TEXT PRIMARY KEY); } + set cookieCount "no" db eval { SELECT COUNT(*) AS cookieCount FROM persistentCookies } - log info "loaded cookie store from $path with $cookieCount entries" + log info "$storeorigin with $cookieCount entries" set aid [after $purgeinterval [namespace current]::my PurgeCookies] @@ -300,7 +307,7 @@ package provide cookiejar $::http::cookiejar_version } } if {$utf ne [IDNAdecode $idna]} { - log warn "mismatch in IDNA handling for $idna" + log warn "mismatch in IDNA handling for $idna ($line, $utf, [IDNAdecode $idna])" } } } -- cgit v0.12 From ea1ff585006fc838c6cf0b75460da81cc60a806b Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 18 Sep 2012 10:15:30 +0000 Subject: Fix the bugs in the punycode decoder --- library/http/cookiejar.tcl | 131 +++++++++++++++++++++++---------------------- library/http/pkgIndex.tcl | 2 +- 2 files changed, 68 insertions(+), 65 deletions(-) diff --git a/library/http/cookiejar.tcl b/library/http/cookiejar.tcl index 86df72b..4382176 100644 --- a/library/http/cookiejar.tcl +++ b/library/http/cookiejar.tcl @@ -21,11 +21,12 @@ namespace eval ::http { # Makefiles variable cookiejar_version 0.1 - # TODO: is this the _right_ list of domains to use? + # TODO: is this the _right_ list of domains to use? Or is there an alias + # for it that will persist longer? variable cookiejar_domainlist \ http://mxr.mozilla.org/mozilla-central/source/netwerk/dns/effective_tld_names.dat?raw=1 variable cookiejar_domainfile \ - [file join [file dirname [info script]] effective_tld_names.txt] + [file join [file dirname [info script]] effective_tld_names.txt.gz] # The list is directed to from http://publicsuffix.org/list/ variable cookiejar_loglevel info variable cookiejar_vacuumtrigger 200 @@ -664,85 +665,87 @@ namespace eval ::http::cookiejar_support::puny { } # Main decode function - proc decode {text {errors "lax"}} { + proc decode {input} { namespace upvar ::http::cookiejar_support::puny \ tmin tmin tmax tmax base base initial_bias initial_bias \ initial_n initial_n maxcodepoint maxcodepoint + # Initialize the state: + set n $initial_n - set pos -1 + set i 0 + set first 1 set bias $initial_bias - set buffer [set chars {}] - set pos [string last "-" $text] - if {$pos >= 0} { - set buffer [split [string range $text 0 [expr {$pos-1}]] ""] - set text [string range $text [expr {$pos+1}] end] - } - set points [split $text ""] - set first true - - for {set extpos 0} {$extpos < [llength $points]} {} { - # Extract the delta, which is the encoding of the character and - # where to insert it. - - set delta 0 - set w 1 - for {set j 1} true {incr j} { - scan [set c [lindex $points $extpos]] "%c" char - if {[string match {[A-Z]} $c]} { - set digit [expr {$char - 0x41}]; # A=0,Z=25 - } elseif {[string match {[a-z]} $c]} { - set digit [expr {$char - 0x61}]; # a=0,z=25 - } elseif {[string match {[0-9]} $c]} { - set digit [expr {$char - 0x30 + 26}]; # 0=26,9=35 + + # 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 {^(?:(.*)-)?([^-]*)$} $input input pre post + 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} "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 { - if {$errors eq "strict"} { - throw {PUNYCODE INVALID} \ - "invalid extended code point '$c'" - } - # There was an error in decoding. We can't continue - # because synchronization is lost. - return [join $buffer ""] + throw {PUNYCODE BAD_INPUT} "bad decode character \"$ch\"" } - - incr extpos - set t [expr {min(max($base*$j - $bias, $tmin), $tmax)}] - incr delta [expr {$digit * $w}] + 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 } - set w [expr {$w * ($base - $t)}] - - if {$extpos >= [llength $points]} { - if {$errors eq "strict"} { - throw {PUNYCODE PARTIAL} "incomplete punycode string" - } - # There was an error in decoding. We can't continue - # because synchronization is lost. - return [join $buffer ""] + if {[set w [expr {$w * ($base - $t)}]] > 0x7fffffff} { + throw {PUNYCODE OVERFLOW} \ + "excessively large integer computed in digit decode" } + incr k $base } - # Now we've got the delta, we can generate the character and - # insert it. + # i was supposed to wrap around from out+1 to 0, incrementing n + # each time, so we'll fix that now: - incr n [expr {[incr pos [expr {$delta+1}]]/([llength $buffer]+1)}] - if {$n > $maxcodepoint} { - if {$errors eq "strict"} { - if {$n < 0x10ffff} { - throw {PUNYCODE NON_BMP} \ - [format "unsupported character U+%06x" $n] - } - throw {PUNYCODE NON_UNICODE} "bad codepoint $n" + if {[incr n [expr {$i / $out}]] > 0x7fffffff} { + throw {PUNYCODE OVERFLOW} \ + "excessively large integer computed in character choice" + } elseif {$n > $maxcodepoint} { + if {$n < 0x10ffff} { + throw {PUNYCODE NON_BMP} \ + [format "unsupported character U+%06x" $n] } - set n 63 ;# "?" - set extpos inf; # We're blowing up anyway... + throw {PUNYCODE NON_UNICODE} "bad codepoint $n" } - set pos [expr {$pos % ([llength $buffer] + 1)}] - set buffer [linsert $buffer $pos [format "%c" $n]] - set bias [adapt $delta $first [llength $buffer]] - set first false + 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 $buffer ""] + + return [join $output ""] } } + +# Local variables: +# mode: tcl +# fill-column: 78 +# End: diff --git a/library/http/pkgIndex.tcl b/library/http/pkgIndex.tcl index 5ce5c37..142a52f 100644 --- a/library/http/pkgIndex.tcl +++ b/library/http/pkgIndex.tcl @@ -1,3 +1,3 @@ if {![package vsatisfies [package provide Tcl] 8.6]} {return} package ifneeded http 2.8.4 [list tclPkgSetup $dir http 2.8.4 {{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 tclPkgSetup $dir cookiejar 0.1 {{cookiejar.tcl source {::http::cookiejar}}}] +package ifneeded cookiejar 0.1 [list source [file join $dir cookiejar.tcl]] -- cgit v0.12 From 82abe83414b4ae3440752ac0fe18c1e21cb39ac7 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 10 Oct 2012 14:49:45 +0000 Subject: reorganize the code so that the IDNA procs live with the punycode procs; correct some misleading (and misleadingly-placed) comments --- library/http/cookiejar.tcl | 77 +++++++++++++++++++++++++++------------------- 1 file changed, 46 insertions(+), 31 deletions(-) diff --git a/library/http/cookiejar.tcl b/library/http/cookiejar.tcl index 4382176..a7691f5 100644 --- a/library/http/cookiejar.tcl +++ b/library/http/cookiejar.tcl @@ -84,28 +84,7 @@ namespace eval ::http { ::http::Log "[isoNow] [string toupper $level] cookiejar($who) - ${msg}" } } - proc IDNAencode str { - set parts {} - # Split term from RFC 3490, Sec 3.1 - foreach part [split $str "\u002E\u3002\uFF0E\uFF61"] { - if {![string is ascii $part]} { - set part xn--[puny::encode $part] - } - lappend parts $part - } - return [join $parts .] - } - proc IDNAdecode str { - set parts {} - # Split term from RFC 3490, Sec 3.1 - foreach part [split $str "\u002E\u3002\uFF0E\uFF61"] { - if {[string match "xn--*" $part]} { - set part [puny::decode [string range $part 4 end]] - } - lappend parts $part - } - return [join $parts .] - } + namespace import ::http::cookiejar_support::puny::IDNA* } } @@ -362,11 +341,15 @@ package provide cookiejar $::http::cookiejar_version 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. if {[regexp {[^0-9.]} $host]} { - # Ugh, it's a numeric domain! Restrict it... db transaction { foreach domain $domains { foreach p $paths { @@ -375,6 +358,7 @@ package provide cookiejar $::http::cookiejar_version } } } else { + # Ugh, it's a numeric domain! Restrict it... db transaction { foreach p $paths { my GetCookiesForHostAndPath result $secure $host $p $host @@ -530,12 +514,43 @@ package provide cookiejar $::http::cookiejar_version } } -# The implementation of the punycode encoder. This is based on the code on -# http://tools.ietf.org/html/rfc3492 (encoder) and http://wiki.tcl.tk/10501 -# (decoder) but with extensive modifications. +# The implementation of the punycode encoder. This is based on the code in +# Appendix C of http://tools.ietf.org/html/rfc3492 but with substantial +# modifications so that it is Tcl code. namespace eval ::http::cookiejar_support::puny { - namespace export encode decode + namespace export IDNAencode punyencode IDNAdecode punydecode + + proc IDNAencode str { + set parts {} + # Split term from RFC 3490, Sec 3.1 + foreach part [split $str "\u002E\u3002\uFF0E\uFF61"] { + if {[regexp {[^-A-Za-z0-9]} $part]} { + if {[regexp {[^-A-Za-z0-9\u0100-\uffff]} $part ch]} { + scan $ch %c c + if {$ch < "!" || $ch > "~"} { + set ch [format "\\u%04x" $c] + } + throw [list IDNA INVALID_NAME_CHARACTER $c] \ + "bad character \"$ch\" in DNS name" + } + set part xn--[punyencode $part] + } + lappend parts $part + } + return [join $parts .] + } + proc IDNAdecode str { + set parts {} + # Split term from RFC 3490, Sec 3.1 + foreach part [split $str "\u002E\u3002\uFF0E\uFF61"] { + if {[string match "xn--*" $part]} { + set part [punydecode [string range $part 4 end]] + } + lappend parts $part + } + return [join $parts .] + } variable digits [split "abcdefghijklmnopqrstuvwxyz0123456789" ""] # Bootstring parameters for Punycode @@ -568,8 +583,8 @@ namespace eval ::http::cookiejar_support::puny { return [expr {$k + ($base-$tmin+1) * $delta / ($delta+$skew)}] } - # Main encode function - proc encode {input {case ""}} { + # Main punycode encoding function + proc punyencode {input {case ""}} { variable digits variable tmin variable tmax @@ -664,8 +679,8 @@ namespace eval ::http::cookiejar_support::puny { return $output } - # Main decode function - proc decode {input} { + # Main punycode decode function + proc punydecode {input} { namespace upvar ::http::cookiejar_support::puny \ tmin tmin tmax tmax base base initial_bias initial_bias \ initial_n initial_n maxcodepoint maxcodepoint -- cgit v0.12 From 2edb721609c87465b723338e7be4db853faf72be Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 12 Oct 2012 13:18:24 +0000 Subject: separating out the IDNA handling code --- library/http/cookiejar.tcl | 336 +++++++-------------------------------------- library/http/idna.tcl | 283 ++++++++++++++++++++++++++++++++++++++ library/http/pkgIndex.tcl | 1 + 3 files changed, 333 insertions(+), 287 deletions(-) create mode 100644 library/http/idna.tcl diff --git a/library/http/cookiejar.tcl b/library/http/cookiejar.tcl index a7691f5..5fa6eb2 100644 --- a/library/http/cookiejar.tcl +++ b/library/http/cookiejar.tcl @@ -11,6 +11,7 @@ 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. @@ -49,10 +50,10 @@ namespace eval ::http { proc locn {secure domain path {key ""}} { if {$key eq ""} { format "%s://%s%s" [expr {$secure?"https":"http"}] \ - [IDNAencode $domain] $path + [tcl::idna encode $domain] $path } else { format "%s://%s%s?%s" \ - [expr {$secure?"https":"http"}] [IDNAencode $domain] \ + [expr {$secure?"https":"http"}] [tcl::idna encode $domain] \ $path $key } } @@ -195,27 +196,24 @@ package provide cookiejar $::http::cookiejar_version my InitDomainList } } - - method InitDomainList {} { - namespace upvar ::http \ - cookiejar_domainlist url \ - cookiejar_domainfile filename \ - cookiejar_offline offline - if {!$offline} { - log debug "loading domain list from $url" - set tok [::http::geturl $url] - try { - if {[::http::ncode $tok] == 200} { - my InstallDomainData [::http::data $tok] - return - } else { - log error "failed to fetch list of forbidden cookie domains from ${url}: [::http::error $tok]" - log warn "attempting to fall back to built in version" - } - } finally { - ::http::cleanup $tok + + method GetDomainListOnline {} { + upvar 0 ::http::cookiejar_domainlist url + log debug "loading domain list from $url" + set tok [::http::geturl $url] + try { + if {[::http::ncode $tok] == 200} { + return [::http::data $tok] + } else { + log error "failed to fetch list of forbidden cookie domains from ${url}: [::http::error $tok]" + return {} } + } finally { + ::http::cleanup $tok } + } + method GetDomainListOffline {} { + upvar 0 ::http::cookiejar_domainfile filename log debug "loading domain list from $filename" try { set f [open $filename] @@ -224,15 +222,27 @@ package provide cookiejar $::http::cookiejar_version zlib push gunzip $f } fconfigure $f -encoding utf-8 - my InstallDomainData [read $f] + return [read $f] } finally { close $f } - } on error msg { + } on error {msg opt} { log error "failed to read list of forbidden cookie domains from ${filename}: $msg" - return -code error $msg + return -options $opt $msg } } + method InitDomainList {} { + upvar 0 ::http::cookiejar_offline offline + if {!$offline} { + set data [my GetDomainListOnline] + if {[string length $data]} { + my InstallDomainData $data + return + } + log warn "attempting to fall back to built in version" + } + my InstallDomainData [my GetDomainListOffline] + } method InstallDomainData {data} { set n [db total_changes] @@ -244,8 +254,8 @@ package provide cookiejar $::http::cookiejar_version continue } elseif {[string match !* $line]} { set line [string range $line 1 end] - set idna [IDNAencode $line] - set utf [IDNAdecode $line] + 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); @@ -259,8 +269,8 @@ package provide cookiejar $::http::cookiejar_version } else { if {[string match {\*.*} $line]} { set line [string range $line 2 end] - set idna [IDNAencode $line] - set utf [IDNAdecode $line] + 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); @@ -272,8 +282,8 @@ package provide cookiejar $::http::cookiejar_version } } } else { - set idna [IDNAencode $line] - set utf [IDNAdecode $line] + 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) @@ -286,8 +296,8 @@ package provide cookiejar $::http::cookiejar_version } } } - if {$utf ne [IDNAdecode $idna]} { - log warn "mismatch in IDNA handling for $idna ($line, $utf, [IDNAdecode $idna])" + if {$utf ne [tcl::idna decode [string tolower $idna]]} { + log warn "mismatch in IDNA handling for $idna ($line, $utf, [tcl::idna decode $idna])" } } } @@ -337,7 +347,7 @@ package provide cookiejar $::http::cookiejar_version method getCookies {proto host path} { set result {} set paths [splitPath $path] - set domains [splitDomain [IDNAencode $host]] + set domains [splitDomain [string tolower [tcl::idna encode $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). @@ -349,17 +359,15 @@ package provide cookiejar $::http::cookiejar_version # 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. - if {[regexp {[^0-9.]} $host]} { - db transaction { + db transaction { + if {[regexp {[^0-9.]} $host]} { foreach domain $domains { foreach p $paths { my GetCookiesForHostAndPath result $secure $domain $p $host } } - } - } else { - # Ugh, it's a numeric domain! Restrict it... - db transaction { + } else { + # Ugh, it's a numeric domain! Restrict it... foreach p $paths { my GetCookiesForHostAndPath result $secure $host $p $host } @@ -479,7 +487,7 @@ package provide cookiejar $::http::cookiejar_version forward Database db method lookup {{host ""} {key ""}} { - set host [IDNAencode $host] + set host [string tolower [tcl::idna encode $host]] db transaction { if {$host eq ""} { set result {} @@ -487,7 +495,7 @@ package provide cookiejar $::http::cookiejar_version SELECT DISTINCT domain FROM cookies ORDER BY domain } { - lappend result [IDNAdecode $domain] + lappend result [tcl::idna decode [string tolower $domain]] } return $result } elseif {$key eq ""} { @@ -514,252 +522,6 @@ package provide cookiejar $::http::cookiejar_version } } -# The implementation of the punycode encoder. This is based on the code in -# Appendix C of http://tools.ietf.org/html/rfc3492 but with substantial -# modifications so that it is Tcl code. - -namespace eval ::http::cookiejar_support::puny { - namespace export IDNAencode punyencode IDNAdecode punydecode - - proc IDNAencode str { - set parts {} - # Split term from RFC 3490, Sec 3.1 - foreach part [split $str "\u002E\u3002\uFF0E\uFF61"] { - if {[regexp {[^-A-Za-z0-9]} $part]} { - if {[regexp {[^-A-Za-z0-9\u0100-\uffff]} $part ch]} { - scan $ch %c c - if {$ch < "!" || $ch > "~"} { - set ch [format "\\u%04x" $c] - } - throw [list IDNA INVALID_NAME_CHARACTER $c] \ - "bad character \"$ch\" in DNS name" - } - set part xn--[punyencode $part] - } - lappend parts $part - } - return [join $parts .] - } - proc IDNAdecode str { - set parts {} - # Split term from RFC 3490, Sec 3.1 - foreach part [split $str "\u002E\u3002\uFF0E\uFF61"] { - if {[string match "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 maxcodepoint 0xFFFF ;# 0x10FFFF would be correct, except Tcl - # can't handle non-BMP characters right now - # anyway. - - 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 {input {case ""}} { - variable digits - variable tmin - variable tmax - variable base - variable initial_n - variable initial_bias - - set in {} - foreach char [set input [split $input ""]] { - 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 $input { - if {$ch < "\u0080"} { - if {$case eq ""} { - append output $ch - } elseif {$case} { - append output [string toupper $ch] - } else { - 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 {input} { - namespace upvar ::http::cookiejar_support::puny \ - tmin tmin tmax tmax base base initial_bias initial_bias \ - initial_n initial_n maxcodepoint maxcodepoint - - # 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 {^(?:(.*)-)?([^-]*)$} $input input pre post - 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} "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} "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 > $maxcodepoint} { - if {$n < 0x10ffff} { - 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 ""] - } -} - # Local variables: # mode: tcl # fill-column: 78 diff --git a/library/http/idna.tcl b/library/http/idna.tcl new file mode 100644 index 0000000..7727e45 --- /dev/null +++ b/library/http/idna.tcl @@ -0,0 +1,283 @@ +# 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). +# +# 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 {::package present 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\u0100-\uffff]} $part ch]} { + scan $ch %c c + if {$ch < "!" || $ch > "~"} { + set ch [format "\\u%04x" $c] + } + throw [list IDNA INVALID_NAME_CHARACTER $c] \ + "bad character \"$ch\" in DNS name" + } + set part xn--[punyencode $part] + } + 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 "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 0xFFFF ;# 0x10FFFF would be correct, except Tcl + # can't handle non-BMP characters right now + # anyway. + + 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} "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} "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 < 0x10ffff} { + 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: diff --git a/library/http/pkgIndex.tcl b/library/http/pkgIndex.tcl index 142a52f..d20ed41 100644 --- a/library/http/pkgIndex.tcl +++ b/library/http/pkgIndex.tcl @@ -1,3 +1,4 @@ if {![package vsatisfies [package provide Tcl] 8.6]} {return} package ifneeded http 2.8.4 [list tclPkgSetup $dir http 2.8.4 {{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 ifndeeded tcl::idna 1.0 [list source [file join $dir idna.tcl]] -- cgit v0.12 From 50cb73a76ef1ac85f26e2ab1e3d5babd6be4e9ca Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 8 Feb 2014 15:36:53 +0000 Subject: update list of TLDs --- library/http/effective_tld_names.txt.gz | Bin 32891 -> 39188 bytes 1 file changed, 0 insertions(+), 0 deletions(-) diff --git a/library/http/effective_tld_names.txt.gz b/library/http/effective_tld_names.txt.gz index a799d16..9ce2b69 100644 Binary files a/library/http/effective_tld_names.txt.gz and b/library/http/effective_tld_names.txt.gz differ -- cgit v0.12 From 334a96f761a2768ff680d31e3cad25eaf63d9bea Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 9 Feb 2014 12:41:05 +0000 Subject: D'oh! --- library/http/pkgIndex.tcl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/library/http/pkgIndex.tcl b/library/http/pkgIndex.tcl index 8b48a9f..2928f88 100644 --- a/library/http/pkgIndex.tcl +++ b/library/http/pkgIndex.tcl @@ -1,4 +1,4 @@ if {![package vsatisfies [package provide Tcl] 8.6]} {return} package ifneeded http 2.8.8 [list tclPkgSetup $dir http 2.8.8 {{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 ifndeeded tcl::idna 1.0 [list source [file join $dir idna.tcl]] +package ifneeded tcl::idna 1.0 [list source [file join $dir idna.tcl]] -- cgit v0.12 From 0cffbf8eb7de60da060b05ae4a06ff19adc24ad6 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 9 Feb 2014 12:56:24 +0000 Subject: starting to write some tests --- library/http/idna.tcl | 2 +- tests/http.test | 26 ++++++++++++++++++++++++++ 2 files changed, 27 insertions(+), 1 deletion(-) diff --git a/library/http/idna.tcl b/library/http/idna.tcl index 7727e45..2b02c33 100644 --- a/library/http/idna.tcl +++ b/library/http/idna.tcl @@ -17,7 +17,7 @@ namespace eval ::tcl::idna { encode IDNAencode decode IDNAdecode puny puny - version {::package present idna} + version {::apply {{} {package present tcl::idna} ::}} } proc IDNAencode hostname { diff --git a/tests/http.test b/tests/http.test index 45dd393..0f7cd0a 100644 --- a/tests/http.test +++ b/tests/http.test @@ -635,6 +635,32 @@ test http-7.4 {http::formatQuery} -setup { http::config -urlencoding $enc } -result {%3F} +package require -exact tcl::idna 1.0 +test http-idna-1.1 {} -returnCodes error -body { + ::tcl::idna +} -result {wrong # args: should be "::tcl::idna subcommand ?arg ...?"} +test http-idna-1.2 {} -returnCodes error -body { + ::tcl::idna ? +} -result {unknown or ambiguous subcommand "?": must be decode, encode, puny, or version} +test http-idna-1.3 {} -body { + ::tcl::idna version +} -result 1.0 +test http-idna-1.4 {} -returnCodes error -body { + ::tcl::idna version what +} -result {wrong # args: should be "::tcl::idna version"} +test http-idna-1.5 {} -returnCodes error -body { + ::tcl::idna puny +} -result {wrong # args: should be "::tcl::idna puny subcommand ?arg ...?"} +test http-idna-1.6 {} -returnCodes error -body { + ::tcl::idna puny ? +} -result {unknown or ambiguous subcommand "?": must be decode, or encode} +test http-idna-1.7 {} -returnCodes error -body { + ::tcl::idna puny encode +} -result {wrong # args: should be "::tcl::idna puny encode string ?case?"} +test http-idna-1.8 {} -returnCodes error -body { + ::tcl::idna puny decode +} -result {wrong # args: should be "::tcl::idna puny decode string ?case?"} + # cleanup catch {unset url} catch {unset badurl} -- cgit v0.12 From ffb8dbaeee4ec56af776d3268065efb96a7611fc Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 13 Feb 2014 09:04:23 +0000 Subject: more tests for the punycode engine --- tests/http.test | 126 ++++++++++++++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 118 insertions(+), 8 deletions(-) diff --git a/tests/http.test b/tests/http.test index 0f7cd0a..8a94c35 100644 --- a/tests/http.test +++ b/tests/http.test @@ -636,30 +636,140 @@ test http-7.4 {http::formatQuery} -setup { } -result {%3F} package require -exact tcl::idna 1.0 -test http-idna-1.1 {} -returnCodes error -body { + +test http-idna-1.1 {IDNA package: basics} -returnCodes error -body { ::tcl::idna } -result {wrong # args: should be "::tcl::idna subcommand ?arg ...?"} -test http-idna-1.2 {} -returnCodes error -body { +test http-idna-1.2 {IDNA package: basics} -returnCodes error -body { ::tcl::idna ? } -result {unknown or ambiguous subcommand "?": must be decode, encode, puny, or version} -test http-idna-1.3 {} -body { +test http-idna-1.3 {IDNA package: basics} -body { ::tcl::idna version } -result 1.0 -test http-idna-1.4 {} -returnCodes error -body { +test http-idna-1.4 {IDNA package: basics} -returnCodes error -body { ::tcl::idna version what } -result {wrong # args: should be "::tcl::idna version"} -test http-idna-1.5 {} -returnCodes error -body { +test http-idna-1.5 {IDNA package: basics} -returnCodes error -body { ::tcl::idna puny } -result {wrong # args: should be "::tcl::idna puny subcommand ?arg ...?"} -test http-idna-1.6 {} -returnCodes error -body { +test http-idna-1.6 {IDNA package: basics} -returnCodes error -body { ::tcl::idna puny ? } -result {unknown or ambiguous subcommand "?": must be decode, or encode} -test http-idna-1.7 {} -returnCodes error -body { +test http-idna-1.7 {IDNA package: basics} -returnCodes error -body { ::tcl::idna puny encode } -result {wrong # args: should be "::tcl::idna puny encode string ?case?"} -test http-idna-1.8 {} -returnCodes error -body { +test http-idna-1.8 {IDNA package: basics} -returnCodes error -body { + ::tcl::idna puny encode a b c +} -result {wrong # args: should be "::tcl::idna puny encode string ?case?"} +test http-idna-1.9 {IDNA package: basics} -returnCodes error -body { ::tcl::idna puny decode } -result {wrong # args: should be "::tcl::idna puny decode string ?case?"} +test http-idna-1.10 {IDNA package: basics} -returnCodes error -body { + ::tcl::idna puny decode a b c +} -result {wrong # args: should be "::tcl::idna puny decode string ?case?"} +test http-idna-1.11 {IDNA package: basics} -returnCodes error -body { + ::tcl::idna decode +} -result {wrong # args: should be "::tcl::idna decode hostname"} +test http-idna-1.12 {IDNA package: basics} -returnCodes error -body { + ::tcl::idna encode +} -result {wrong # args: should be "::tcl::idna encode hostname"} + +test http-idna-2.1 {puny encode: functional test} { + ::tcl::idna puny encode abc +} abc- +test http-idna-2.2 {puny encode: functional test} { + ::tcl::idna puny encode a\u20acb\u20acc +} abc-k50ab +test http-idna-2.3 {puny encode: functional test} { + ::tcl::idna puny encode ABC +} ABC- +test http-idna-2.4 {puny encode: functional test} { + ::tcl::idna puny encode A\u20ACB\u20ACC +} ABC-k50ab +test http-idna-2.5 {puny encode: functional test} { + ::tcl::idna puny encode ABC 0 +} abc- +test http-idna-2.6 {puny encode: functional test} { + ::tcl::idna puny encode A\u20ACB\u20ACC 0 +} abc-k50ab +test http-idna-2.7 {puny encode: functional test} { + ::tcl::idna puny encode ABC 1 +} ABC- +test http-idna-2.8 {puny encode: functional test} { + ::tcl::idna puny encode A\u20ACB\u20ACC 1 +} ABC-k50ab +test http-idna-2.9 {puny encode: functional test} { + ::tcl::idna puny encode abc 0 +} abc- +test http-idna-2.10 {puny encode: functional test} { + ::tcl::idna puny encode a\u20ACb\u20ACc 0 +} abc-k50ab +test http-idna-2.11 {puny encode: functional test} { + ::tcl::idna puny encode abc 1 +} ABC- +test http-idna-2.12 {puny encode: functional test} { + ::tcl::idna puny encode a\u20ACb\u20ACc 1 +} ABC-k50ab +test http-idna-2.13 {puny encode: edge cases} { + ::tcl::idna puny encode "" +} "" + +test http-idna-3.1 {puny decode: functional test} { + ::tcl::idna puny decode abc- +} abc +test http-idna-3.2 {puny decode: functional test} { + ::tcl::idna puny decode abc-k50ab +} a\u20acb\u20acc +test http-idna-3.3 {puny decode: functional test} { + ::tcl::idna puny decode ABC- +} ABC +test http-idna-3.4 {puny decode: functional test} { + ::tcl::idna puny decode ABC-k50ab +} A\u20ACB\u20ACC +test http-idna-3.5 {puny decode: functional test} { + ::tcl::idna puny decode ABC-K50AB +} A\u20ACB\u20ACC +test http-idna-3.6 {puny decode: functional test} { + ::tcl::idna puny decode abc-K50AB +} a\u20ACb\u20ACc +test http-idna-3.7 {puny decode: functional test} { + ::tcl::idna puny decode ABC- 0 +} abc +test http-idna-3.8 {puny decode: functional test} { + ::tcl::idna puny decode ABC-K50AB 0 +} a\u20ACb\u20ACc +test http-idna-3.9 {puny decode: functional test} { + ::tcl::idna puny decode ABC- 1 +} ABC +test http-idna-3.10 {puny decode: functional test} { + ::tcl::idna puny decode ABC-K50AB 1 +} A\u20ACB\u20ACC +test http-idna-3.11 {puny decode: functional test} { + ::tcl::idna puny decode abc- 0 +} abc +test http-idna-3.12 {puny decode: functional test} { + ::tcl::idna puny decode abc-k50ab 0 +} a\u20ACb\u20ACc +test http-idna-3.13 {puny decode: functional test} { + ::tcl::idna puny decode abc- 1 +} ABC +test http-idna-3.14 {puny decode: functional test} { + ::tcl::idna puny decode abc-k50ab 1 +} A\u20ACB\u20ACC +test http-idna-3.15 {puny decode: edge cases and errors} { + # Is this case actually correct? + binary encode hex [encoding convertto utf-8 [::tcl::idna puny decode abc]] +} c282c281c280 +test http-idna-3.16 {puny decode: edge cases and errors} -returnCodes error -body { + ::tcl::idna puny decode abc! +} -result {bad decode character "!"} +test http-idna-3.17 {puny decode: edge cases and errors} { + catch {::tcl::idna puny decode abc!} -> opt + dict get $opt -errorcode +} {PUNYCODE BAD_INPUT} +test http-idna-3.18 {puny decode: edge cases and errors} { + ::tcl::idna puny decode "" +} {} # cleanup catch {unset url} -- cgit v0.12 From 355793810091ea96c89cee861e47d3e2b81e4bba Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 14 Feb 2014 09:03:49 +0000 Subject: more tests, now getting to the IDNA handling --- library/http/idna.tcl | 2 +- tests/http.test | 46 ++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 47 insertions(+), 1 deletion(-) diff --git a/library/http/idna.tcl b/library/http/idna.tcl index 2b02c33..a73d113 100644 --- a/library/http/idna.tcl +++ b/library/http/idna.tcl @@ -43,7 +43,7 @@ namespace eval ::tcl::idna { set parts {} # Split term from RFC 3490, Sec 3.1 foreach part [split $hostname "\u002E\u3002\uFF0E\uFF61"] { - if {[string match "xn--*" $part]} { + if {[string match -nocase "xn--*" $part]} { set part [punydecode [string range $part 4 end]] } lappend parts $part diff --git a/tests/http.test b/tests/http.test index 8a94c35..aa8340c 100644 --- a/tests/http.test +++ b/tests/http.test @@ -770,6 +770,52 @@ test http-idna-3.17 {puny decode: edge cases and errors} { test http-idna-3.18 {puny decode: edge cases and errors} { ::tcl::idna puny decode "" } {} + +test http-idna-4.1 {IDNA encoding} { + ::tcl::idna encode abc.def +} abc.def +test http-idna-4.2 {IDNA encoding} { + ::tcl::idna encode a\u20acb\u20acc.def +} xn--abc-k50ab.def +test http-idna-4.3 {IDNA encoding} { + ::tcl::idna encode def.a\u20acb\u20acc +} def.xn--abc-k50ab +test http-idna-4.4 {IDNA encoding} { + ::tcl::idna encode ABC.DEF +} ABC.DEF +test http-idna-4.5 {IDNA encoding} { + ::tcl::idna encode A\u20acB\u20acC.def +} xn--ABC-k50ab.def +test http-idna-4.6 {IDNA encoding: invalid edge case} { + # Should this be an error? + ::tcl::idna encode abc..def +} abc..def +test http-idna-4.7 {IDNA encoding: invalid char} -returnCodes error -body { + ::tcl::idna encode abc.$.def +} -result {bad character "$" in DNS name} +test http-idna-4.7.1 {IDNA encoding: invalid char} { + catch {::tcl::idna encode abc.$.def} -> opt + dict get $opt -errorcode +} {IDNA INVALID_NAME_CHARACTER 36} +test http-idna-4.8 {IDNA encoding: empty} { + ::tcl::idna encode "" +} {} + +test http-idna-5.1 {IDNA decoding} { + ::tcl::idna decode abc.def +} abc.def +test http-idna-5.2 {IDNA decoding} { + # Invalid entry that's just a wrapper + ::tcl::idna decode xn--abc-.def +} abc.def +test http-idna-5.3 {IDNA decoding} { + # Invalid entry that's just a wrapper + ::tcl::idna decode xn--abc-.xn--def- +} abc.def +test http-idna-5.4 {IDNA decoding} { + # Invalid entry that's just a wrapper + ::tcl::idna decode XN--abc-.XN--def- +} abc.def # cleanup catch {unset url} -- cgit v0.12 From 1c6910c2ec785c4ed4dbd27ed84206e43c7186c6 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 15 Feb 2014 10:02:43 +0000 Subject: add the test cases from RFC 3492 --- tests/http.test | 233 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 233 insertions(+) diff --git a/tests/http.test b/tests/http.test index aa8340c..a1da46b 100644 --- a/tests/http.test +++ b/tests/http.test @@ -713,6 +713,125 @@ test http-idna-2.12 {puny encode: functional test} { test http-idna-2.13 {puny encode: edge cases} { ::tcl::idna puny encode "" } "" +test http-idna-2.14-A {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode [join [subst [string map {u+ \\u} { + u+0644 u+064A u+0647 u+0645 u+0627 u+0628 u+062A u+0643 u+0644 + u+0645 u+0648 u+0634 u+0639 u+0631 u+0628 u+064A u+061F + }]] ""] +} egbpdaj6bu4bxfgehfvwxn +test http-idna-2.14-B {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode [join [subst [string map {u+ \\u} { + u+4ED6 u+4EEC u+4E3A u+4EC0 u+4E48 u+4E0D u+8BF4 u+4E2D u+6587 + }]] ""] +} ihqwcrb4cv8a8dqg056pqjye +test http-idna-2.14-C {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode [join [subst [string map {u+ \\u} { + u+4ED6 u+5011 u+7232 u+4EC0 u+9EBD u+4E0D u+8AAA u+4E2D u+6587 + }]] ""] +} ihqwctvzc91f659drss3x8bo0yb +test http-idna-2.14-D {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode [join [subst [string map {u+ \\u} { + u+0050 u+0072 u+006F u+010D u+0070 u+0072 u+006F u+0073 u+0074 + u+011B u+006E u+0065 u+006D u+006C u+0075 u+0076 u+00ED u+010D + u+0065 u+0073 u+006B u+0079 + }]] ""] +} Proprostnemluvesky-uyb24dma41a +test http-idna-2.14-E {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode [join [subst [string map {u+ \\u} { + u+05DC u+05DE u+05D4 u+05D4 u+05DD u+05E4 u+05E9 u+05D5 u+05D8 + u+05DC u+05D0 u+05DE u+05D3 u+05D1 u+05E8 u+05D9 u+05DD u+05E2 + u+05D1 u+05E8 u+05D9 u+05EA + }]] ""] +} 4dbcagdahymbxekheh6e0a7fei0b +test http-idna-2.14-F {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode [join [subst [string map {u+ \\u} { + u+092F u+0939 u+0932 u+094B u+0917 u+0939 u+093F u+0928 u+094D + u+0926 u+0940 u+0915 u+094D u+092F u+094B u+0902 u+0928 u+0939 + u+0940 u+0902 u+092C u+094B u+0932 u+0938 u+0915 u+0924 u+0947 + u+0939 u+0948 u+0902 + }]] ""] +} i1baa7eci9glrd9b2ae1bj0hfcgg6iyaf8o0a1dig0cd +test http-idna-2.14-G {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode [join [subst [string map {u+ \\u} { + u+306A u+305C u+307F u+3093 u+306A u+65E5 u+672C u+8A9E u+3092 + u+8A71 u+3057 u+3066 u+304F u+308C u+306A u+3044 u+306E u+304B + }]] ""] +} n8jok5ay5dzabd5bym9f0cm5685rrjetr6pdxa +test http-idna-2.14-H {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode [join [subst [string map {u+ \\u} { + u+C138 u+ACC4 u+C758 u+BAA8 u+B4E0 u+C0AC u+B78C u+B4E4 u+C774 + u+D55C u+AD6D u+C5B4 u+B97C u+C774 u+D574 u+D55C u+B2E4 u+BA74 + u+C5BC u+B9C8 u+B098 u+C88B u+C744 u+AE4C + }]] ""] +} 989aomsvi5e83db1d2a355cv1e0vak1dwrv93d5xbh15a0dt30a5jpsd879ccm6fea98c +test http-idna-2.14-I {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode [join [subst [string map {u+ \\u} { + u+043F u+043E u+0447 u+0435 u+043C u+0443 u+0436 u+0435 u+043E + u+043D u+0438 u+043D u+0435 u+0433 u+043E u+0432 u+043E u+0440 + u+044F u+0442 u+043F u+043E u+0440 u+0443 u+0441 u+0441 u+043A + u+0438 + }]] ""] +} b1abfaaepdrnnbgefbadotcwatmq2g4l +test http-idna-2.14-J {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode [join [subst [string map {u+ \\u} { + u+0050 u+006F u+0072 u+0071 u+0075 u+00E9 u+006E u+006F u+0070 + u+0075 u+0065 u+0064 u+0065 u+006E u+0073 u+0069 u+006D u+0070 + u+006C u+0065 u+006D u+0065 u+006E u+0074 u+0065 u+0068 u+0061 + u+0062 u+006C u+0061 u+0072 u+0065 u+006E u+0045 u+0073 u+0070 + u+0061 u+00F1 u+006F u+006C + }]] ""] +} PorqunopuedensimplementehablarenEspaol-fmd56a +test http-idna-2.14-K {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode [join [subst [string map {u+ \\u} { + u+0054 u+1EA1 u+0069 u+0073 u+0061 u+006F u+0068 u+1ECD u+006B + u+0068 u+00F4 u+006E u+0067 u+0074 u+0068 u+1EC3 u+0063 u+0068 + u+1EC9 u+006E u+00F3 u+0069 u+0074 u+0069 u+1EBF u+006E u+0067 + u+0056 u+0069 u+1EC7 u+0074 + }]] ""] +} TisaohkhngthchnitingVit-kjcr8268qyxafd2f1b9g +test http-idna-2.14-L {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode [join [subst [string map {u+ \\u} { + u+0033 u+5E74 u+0042 u+7D44 u+91D1 u+516B u+5148 u+751F + }]] ""] +} 3B-ww4c5e180e575a65lsy2b +test http-idna-2.14-M {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode [join [subst [string map {u+ \\u} { + u+5B89 u+5BA4 u+5948 u+7F8E u+6075 u+002D u+0077 u+0069 u+0074 + u+0068 u+002D u+0053 u+0055 u+0050 u+0045 u+0052 u+002D u+004D + u+004F u+004E u+004B u+0045 u+0059 u+0053 + }]] ""] +} -with-SUPER-MONKEYS-pc58ag80a8qai00g7n9n +test http-idna-2.14-N {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode [join [subst [string map {u+ \\u} { + u+0048 u+0065 u+006C u+006C u+006F u+002D u+0041 u+006E u+006F + u+0074 u+0068 u+0065 u+0072 u+002D u+0057 u+0061 u+0079 u+002D + u+305D u+308C u+305E u+308C u+306E u+5834 u+6240 + }]] ""] +} Hello-Another-Way--fc4qua05auwb3674vfr0b +test http-idna-2.14-O {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode [join [subst [string map {u+ \\u} { + u+3072 u+3068 u+3064 u+5C4B u+6839 u+306E u+4E0B u+0032 + }]] ""] +} 2-u9tlzr9756bt3uc0v +test http-idna-2.14-P {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode [join [subst [string map {u+ \\u} { + u+004D u+0061 u+006A u+0069 u+3067 u+004B u+006F u+0069 u+3059 + u+308B u+0035 u+79D2 u+524D + }]] ""] +} MajiKoi5-783gue6qz075azm5e +test http-idna-2.14-Q {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode [join [subst [string map {u+ \\u} { + u+30D1 u+30D5 u+30A3 u+30FC u+0064 u+0065 u+30EB u+30F3 u+30D0 + }]] ""] +} de-jg4avhby1noc0d +test http-idna-2.14-R {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode [join [subst [string map {u+ \\u} { + u+305D u+306E u+30B9 u+30D4 u+30FC u+30C9 u+3067 + }]] ""] +} d9juau41awczczp +test http-idna-2.14-S {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode {-> $1.00 <-} +} {-> $1.00 <--} test http-idna-3.1 {puny decode: functional test} { ::tcl::idna puny decode abc- @@ -770,6 +889,120 @@ test http-idna-3.17 {puny decode: edge cases and errors} { test http-idna-3.18 {puny decode: edge cases and errors} { ::tcl::idna puny decode "" } {} +# A helper so we don't get lots of crap in failures +proc hexify s {lmap c [split $s ""] {format u+%04X [scan $c %c]}} +test http-idna-3.19-A {puny decode: examples from RFC 3492} { + hexify [::tcl::idna puny decode egbpdaj6bu4bxfgehfvwxn] +} [list {*}{ + u+0644 u+064A u+0647 u+0645 u+0627 u+0628 u+062A u+0643 u+0644 + u+0645 u+0648 u+0634 u+0639 u+0631 u+0628 u+064A u+061F +}] +test http-idna-3.19-B {puny decode: examples from RFC 3492} { + hexify [::tcl::idna puny decode ihqwcrb4cv8a8dqg056pqjye] +} {u+4ED6 u+4EEC u+4E3A u+4EC0 u+4E48 u+4E0D u+8BF4 u+4E2D u+6587} +test http-idna-3.19-C {puny decode: examples from RFC 3492} { + hexify [::tcl::idna puny decode ihqwctvzc91f659drss3x8bo0yb] +} {u+4ED6 u+5011 u+7232 u+4EC0 u+9EBD u+4E0D u+8AAA u+4E2D u+6587} +test http-idna-3.19-D {puny decode: examples from RFC 3492} { + hexify [::tcl::idna puny decode Proprostnemluvesky-uyb24dma41a] +} [list {*}{ + u+0050 u+0072 u+006F u+010D u+0070 u+0072 u+006F u+0073 u+0074 + u+011B u+006E u+0065 u+006D u+006C u+0075 u+0076 u+00ED u+010D + u+0065 u+0073 u+006B u+0079 +}] +test http-idna-3.19-E {puny decode: examples from RFC 3492} { + hexify [::tcl::idna puny decode 4dbcagdahymbxekheh6e0a7fei0b] +} [list {*}{ + u+05DC u+05DE u+05D4 u+05D4 u+05DD u+05E4 u+05E9 u+05D5 u+05D8 + u+05DC u+05D0 u+05DE u+05D3 u+05D1 u+05E8 u+05D9 u+05DD u+05E2 + u+05D1 u+05E8 u+05D9 u+05EA +}] +test http-idna-3.19-F {puny decode: examples from RFC 3492} { + hexify [::tcl::idna puny decode \ + i1baa7eci9glrd9b2ae1bj0hfcgg6iyaf8o0a1dig0cd] +} [list {*}{ + u+092F u+0939 u+0932 u+094B u+0917 u+0939 u+093F u+0928 u+094D + u+0926 u+0940 u+0915 u+094D u+092F u+094B u+0902 u+0928 u+0939 + u+0940 u+0902 u+092C u+094B u+0932 u+0938 u+0915 u+0924 u+0947 + u+0939 u+0948 u+0902 +}] +test http-idna-3.19-G {puny decode: examples from RFC 3492} { + hexify [::tcl::idna puny decode n8jok5ay5dzabd5bym9f0cm5685rrjetr6pdxa] +} [list {*}{ + u+306A u+305C u+307F u+3093 u+306A u+65E5 u+672C u+8A9E u+3092 + u+8A71 u+3057 u+3066 u+304F u+308C u+306A u+3044 u+306E u+304B +}] +test http-idna-3.19-H {puny decode: examples from RFC 3492} { + hexify [::tcl::idna puny decode \ + 989aomsvi5e83db1d2a355cv1e0vak1dwrv93d5xbh15a0dt30a5jpsd879ccm6fea98c] +} [list {*}{ + u+C138 u+ACC4 u+C758 u+BAA8 u+B4E0 u+C0AC u+B78C u+B4E4 u+C774 + u+D55C u+AD6D u+C5B4 u+B97C u+C774 u+D574 u+D55C u+B2E4 u+BA74 + u+C5BC u+B9C8 u+B098 u+C88B u+C744 u+AE4C +}] +test http-idna-3.19-I {puny decode: examples from RFC 3492} { + hexify [::tcl::idna puny decode b1abfaaepdrnnbgefbadotcwatmq2g4l] +} [list {*}{ + u+043F u+043E u+0447 u+0435 u+043C u+0443 u+0436 u+0435 u+043E + u+043D u+0438 u+043D u+0435 u+0433 u+043E u+0432 u+043E u+0440 + u+044F u+0442 u+043F u+043E u+0440 u+0443 u+0441 u+0441 u+043A + u+0438 +}] +test http-idna-3.19-J {puny decode: examples from RFC 3492} { + hexify [::tcl::idna puny decode \ + PorqunopuedensimplementehablarenEspaol-fmd56a] +} [list {*}{ + u+0050 u+006F u+0072 u+0071 u+0075 u+00E9 u+006E u+006F u+0070 + u+0075 u+0065 u+0064 u+0065 u+006E u+0073 u+0069 u+006D u+0070 + u+006C u+0065 u+006D u+0065 u+006E u+0074 u+0065 u+0068 u+0061 + u+0062 u+006C u+0061 u+0072 u+0065 u+006E u+0045 u+0073 u+0070 + u+0061 u+00F1 u+006F u+006C +}] +test http-idna-3.19-K {puny decode: examples from RFC 3492} { + hexify [::tcl::idna puny decode \ + TisaohkhngthchnitingVit-kjcr8268qyxafd2f1b9g] +} [list {*}{ + u+0054 u+1EA1 u+0069 u+0073 u+0061 u+006F u+0068 u+1ECD u+006B + u+0068 u+00F4 u+006E u+0067 u+0074 u+0068 u+1EC3 u+0063 u+0068 + u+1EC9 u+006E u+00F3 u+0069 u+0074 u+0069 u+1EBF u+006E u+0067 + u+0056 u+0069 u+1EC7 u+0074 +}] +test http-idna-3.19-L {puny decode: examples from RFC 3492} { + hexify [::tcl::idna puny decode 3B-ww4c5e180e575a65lsy2b] +} {u+0033 u+5E74 u+0042 u+7D44 u+91D1 u+516B u+5148 u+751F} +test http-idna-3.19-M {puny decode: examples from RFC 3492} { + hexify [::tcl::idna puny decode -with-SUPER-MONKEYS-pc58ag80a8qai00g7n9n] +} [list {*}{ + u+5B89 u+5BA4 u+5948 u+7F8E u+6075 u+002D u+0077 u+0069 u+0074 + u+0068 u+002D u+0053 u+0055 u+0050 u+0045 u+0052 u+002D u+004D + u+004F u+004E u+004B u+0045 u+0059 u+0053 +}] +test http-idna-3.19-N {puny decode: examples from RFC 3492} { + hexify [::tcl::idna puny decode Hello-Another-Way--fc4qua05auwb3674vfr0b] +} [list {*}{ + u+0048 u+0065 u+006C u+006C u+006F u+002D u+0041 u+006E u+006F + u+0074 u+0068 u+0065 u+0072 u+002D u+0057 u+0061 u+0079 u+002D + u+305D u+308C u+305E u+308C u+306E u+5834 u+6240 +}] +test http-idna-3.19-O {puny decode: examples from RFC 3492} { + hexify [::tcl::idna puny decode 2-u9tlzr9756bt3uc0v] +} {u+3072 u+3068 u+3064 u+5C4B u+6839 u+306E u+4E0B u+0032} +test http-idna-3.19-P {puny decode: examples from RFC 3492} { + hexify [::tcl::idna puny decode MajiKoi5-783gue6qz075azm5e] +} [list {*}{ + u+004D u+0061 u+006A u+0069 u+3067 u+004B u+006F u+0069 u+3059 + u+308B u+0035 u+79D2 u+524D +}] +test http-idna-3.19-Q {puny decode: examples from RFC 3492} { + hexify [::tcl::idna puny decode de-jg4avhby1noc0d] +} {u+30D1 u+30D5 u+30A3 u+30FC u+0064 u+0065 u+30EB u+30F3 u+30D0} +test http-idna-3.19-R {puny decode: examples from RFC 3492} { + hexify [::tcl::idna puny decode d9juau41awczczp] +} {u+305D u+306E u+30B9 u+30D4 u+30FC u+30C9 u+3067} +test http-idna-3.19-S {puny decode: examples from RFC 3492} { + ::tcl::idna puny decode {-> $1.00 <--} +} {-> $1.00 <-} +rename hexify "" test http-idna-4.1 {IDNA encoding} { ::tcl::idna encode abc.def -- cgit v0.12 From 9b6ba772240147bd21bb1c4c0173ed2f4e794f84 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 16 Feb 2014 09:04:44 +0000 Subject: extending the IDNA tests --- library/http/idna.tcl | 12 +++++++++--- tests/http.test | 31 +++++++++++++++++++++++++++++-- 2 files changed, 38 insertions(+), 5 deletions(-) diff --git a/library/http/idna.tcl b/library/http/idna.tcl index a73d113..7dfb968 100644 --- a/library/http/idna.tcl +++ b/library/http/idna.tcl @@ -30,10 +30,15 @@ namespace eval ::tcl::idna { if {$ch < "!" || $ch > "~"} { set ch [format "\\u%04x" $c] } - throw [list IDNA INVALID_NAME_CHARACTER $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 } @@ -226,7 +231,7 @@ namespace eval ::tcl::idna { 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} "exceeded input data" + throw {PUNYCODE BAD_INPUT LENGTH} "exceeded input data" } if {[string match -nocase {[a-z]} $ch]} { scan [string toupper $ch] %c digit @@ -234,7 +239,8 @@ namespace eval ::tcl::idna { } elseif {[string match {[0-9]} $ch]} { set digit [expr {$ch + 26}] } else { - throw {PUNYCODE BAD_INPUT} "bad decode character \"$ch\"" + throw {PUNYCODE BAD_INPUT CHAR} \ + "bad decode character \"$ch\"" } incr i [expr {$digit * $w}] set t [expr {min(max($tmin, $k-$bias), $tmax)}] diff --git a/tests/http.test b/tests/http.test index a1da46b..0f76258 100644 --- a/tests/http.test +++ b/tests/http.test @@ -885,7 +885,7 @@ test http-idna-3.16 {puny decode: edge cases and errors} -returnCodes error -bod test http-idna-3.17 {puny decode: edge cases and errors} { catch {::tcl::idna puny decode abc!} -> opt dict get $opt -errorcode -} {PUNYCODE BAD_INPUT} +} {PUNYCODE BAD_INPUT CHAR} test http-idna-3.18 {puny decode: edge cases and errors} { ::tcl::idna puny decode "" } {} @@ -1029,10 +1029,23 @@ test http-idna-4.7 {IDNA encoding: invalid char} -returnCodes error -body { test http-idna-4.7.1 {IDNA encoding: invalid char} { catch {::tcl::idna encode abc.$.def} -> opt dict get $opt -errorcode -} {IDNA INVALID_NAME_CHARACTER 36} +} {IDNA INVALID_NAME_CHARACTER {$}} test http-idna-4.8 {IDNA encoding: empty} { ::tcl::idna encode "" } {} +set overlong www.[join [subst [string map {u+ \\u} { + u+C138 u+ACC4 u+C758 u+BAA8 u+B4E0 u+C0AC u+B78C u+B4E4 u+C774 + u+D55C u+AD6D u+C5B4 u+B97C u+C774 u+D574 u+D55C u+B2E4 u+BA74 + u+C5BC u+B9C8 u+B098 u+C88B u+C744 u+AE4C +}]] ""].com +test http-idna-4.9 {IDNA encoding: max lengths from RFC 5890} -body { + ::tcl::idna encode $overlong +} -returnCodes error -result "hostname part too long" +test http-idna-4.9.1 {IDNA encoding: max lengths from RFC 5890} { + catch {::tcl::idna encode $overlong} -> opt + dict get $opt -errorcode +} {IDNA OVERLONG_PART xn--989aomsvi5e83db1d2a355cv1e0vak1dwrv93d5xbh15a0dt30a5jpsd879ccm6fea98c} +unset overlong test http-idna-5.1 {IDNA decoding} { ::tcl::idna decode abc.def @@ -1049,6 +1062,20 @@ test http-idna-5.4 {IDNA decoding} { # Invalid entry that's just a wrapper ::tcl::idna decode XN--abc-.XN--def- } abc.def +test http-idna-5.5 {IDNA decoding: error cases} -returnCodes error -body { + ::tcl::idna decode xn--$$$.example.com +} -result {bad decode character "$"} +test http-idna-5.5.1 {IDNA decoding: error cases} { + catch {::tcl::idna decode xn--$$$.example.com} -> opt + dict get $opt -errorcode +} {PUNYCODE BAD_INPUT CHAR} +test http-idna-5.6 {IDNA decoding: error cases} -returnCodes error -body { + ::tcl::idna decode xn--a-zzzzzzzzzzzzzzzzzzzzzzzzzzzzzz.def +} -result {exceeded input data} +test http-idna-5.6.1 {IDNA decoding: error cases} { + catch {::tcl::idna decode xn--a-zzzzzzzzzzzzzzzzzzzzzzzzzzzzzz.def} -> opt + dict get $opt -errorcode +} {PUNYCODE BAD_INPUT LENGTH} # cleanup catch {unset url} -- cgit v0.12 From 96c666ffcf7708b61f36932ba164e4018cd02fb8 Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 18 Feb 2014 14:14:33 +0000 Subject: testing of the cookiejar implementation --- library/http/cookiejar.tcl | 58 ++++++++--------- tests/httpcookie.test | 157 +++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 186 insertions(+), 29 deletions(-) create mode 100644 tests/httpcookie.test diff --git a/library/http/cookiejar.tcl b/library/http/cookiejar.tcl index 5fa6eb2..3df52f0 100644 --- a/library/http/cookiejar.tcl +++ b/library/http/cookiejar.tcl @@ -35,7 +35,9 @@ namespace eval ::http { variable cookiejar_purgeinterval 60000 # This is the class that we are creating - ::oo::class create cookiejar + if {![llength [info commands cookiejar]]} { + ::oo::class create cookiejar + } # Some support procedures, none particularly useful in general namespace eval cookiejar_support { @@ -50,10 +52,10 @@ namespace eval ::http { proc locn {secure domain path {key ""}} { if {$key eq ""} { format "%s://%s%s" [expr {$secure?"https":"http"}] \ - [tcl::idna encode $domain] $path + [::tcl::idna encode $domain] $path } else { format "%s://%s%s?%s" \ - [expr {$secure?"https":"http"}] [tcl::idna encode $domain] \ + [expr {$secure?"https":"http"}] [::tcl::idna encode $domain] \ $path $key } } @@ -85,7 +87,6 @@ namespace eval ::http { ::http::Log "[isoNow] [string toupper $level] cookiejar($who) - ${msg}" } } - namespace import ::http::cookiejar_support::puny::IDNA* } } @@ -96,10 +97,9 @@ package provide cookiejar $::http::cookiejar_version ::oo::define ::http::cookiejar { self method loglevel {{level "\u0000\u0000"}} { namespace upvar ::http cookiejar_loglevel loglevel - if {$level in {debug info warn error}} { - set loglevel $level - } elseif {$level ne "\u0000\u0000"} { - return -code error "unknown log level \"$level\": must be debug, info, warn, or error" + if {$level ne "\u0000\u0000"} { + set loglevel [::tcl::prefix match -message "log level" \ + {debug info warn error} $level] } return $loglevel } @@ -254,8 +254,8 @@ package provide cookiejar $::http::cookiejar_version 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]] + 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); @@ -269,8 +269,8 @@ package provide cookiejar $::http::cookiejar_version } 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]] + 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); @@ -282,8 +282,8 @@ package provide cookiejar $::http::cookiejar_version } } } else { - set idna [string tolower [tcl::idna encode $line]] - set utf [tcl::idna decode [string tolower $line]] + 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) @@ -296,8 +296,8 @@ package provide cookiejar $::http::cookiejar_version } } } - if {$utf ne [tcl::idna decode [string tolower $idna]]} { - log warn "mismatch in IDNA handling for $idna ($line, $utf, [tcl::idna decode $idna])" + if {$utf ne [::tcl::idna decode [string tolower $idna]]} { + log warn "mismatch in IDNA handling for $idna ($line, $utf, [::tcl::idna decode $idna])" } } } @@ -347,7 +347,7 @@ package provide cookiejar $::http::cookiejar_version method getCookies {proto host path} { set result {} set paths [splitPath $path] - set domains [splitDomain [string tolower [tcl::idna encode $host]]] + set domains [splitDomain [string tolower [::tcl::idna encode $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). @@ -409,7 +409,7 @@ package provide cookiejar $::http::cookiejar_version return 0 } - method storeCookie {name val options} { + method storeCookie {name value options} { set now [clock seconds] db transaction { if {[my BadDomain $options]} { @@ -421,36 +421,36 @@ package provide cookiejar $::http::cookiejar_version db eval { INSERT OR REPLACE INTO sessionCookies ( secure, domain, path, key, value, originonly, creation, lastuse) - VALUES ($secure, $domain, $path, $key, $value, $hostonly, $now, $now); + VALUES ($secure, $domain, $path, $name, $value, $hostonly, $now, $now); DELETE FROM persistentCookies - WHERE domain = $domain AND path = $path AND key = $key AND secure <= $secure + WHERE domain = $domain AND path = $path AND key = $name AND secure <= $secure } incr deletions [db changes] - log debug "defined session cookie for [locn $secure $domain $path $key]" + log debug "defined session cookie for [locn $secure $domain $path $name]" } elseif {$expires < $now} { db eval { DELETE FROM persistentCookies - WHERE domain = $domain AND path = $path AND key = $key + WHERE domain = $domain AND path = $path AND key = $name AND secure <= $secure; } set del [db changes] db eval { DELETE FROM sessionCookies - WHERE domain = $domain AND path = $path AND key = $key + WHERE domain = $domain AND path = $path AND key = $name AND secure <= $secure; } incr deletions [incr del [db changes]] - log debug "deleted $del cookies for [locn $secure $domain $path $key]" + log debug "deleted $del cookies for [locn $secure $domain $path $name]" } else { db eval { INSERT OR REPLACE INTO persistentCookies ( secure, domain, path, key, value, originonly, expiry, creation) - VALUES ($secure, $domain, $path, $key, $value, $hostonly, $expires, $now); + VALUES ($secure, $domain, $path, $name, $value, $hostonly, $expires, $now); DELETE FROM sessionCookies - WHERE domain = $domain AND path = $path AND key = $key AND secure <= $secure + WHERE domain = $domain AND path = $path AND key = $name AND secure <= $secure } incr deletions [db changes] - log debug "defined persistent cookie for [locn $secure $domain $path $key], expires at [clock format $expires]" + log debug "defined persistent cookie for [locn $secure $domain $path $name], expires at [clock format $expires]" } } } @@ -487,7 +487,7 @@ package provide cookiejar $::http::cookiejar_version forward Database db method lookup {{host ""} {key ""}} { - set host [string tolower [tcl::idna encode $host]] + set host [string tolower [::tcl::idna encode $host]] db transaction { if {$host eq ""} { set result {} @@ -495,7 +495,7 @@ package provide cookiejar $::http::cookiejar_version SELECT DISTINCT domain FROM cookies ORDER BY domain } { - lappend result [tcl::idna decode [string tolower $domain]] + lappend result [::tcl::idna decode [string tolower $domain]] } return $result } elseif {$key eq ""} { diff --git a/tests/httpcookie.test b/tests/httpcookie.test new file mode 100644 index 0000000..d2c4de8 --- /dev/null +++ b/tests/httpcookie.test @@ -0,0 +1,157 @@ +# Commands covered: http::cookiejar +# +# This file contains a collection of tests for the cookiejar package. +# Sourcing this file into Tcl runs the tests and generates output for errors. +# No output means no errors were found. +# +# Copyright (c) 2014 Donal K. Fellows. +# +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. + +package require tcltest 2 +namespace import -force ::tcltest::* + +testConstraint cookiejar [expr {![catch { + package require cookiejar +}]}] + +test http-cookiejar-1.1 {cookie storage: packaging} cookiejar { + package require cookiejar +} 0.1 +test http-cookiejar-1.2 {cookie storage: packaging} cookiejar { + package require cookiejar + package require cookiejar +} 0.1 + +test http-cookiejar-2.1 {cookie storage: basics} -constraints cookiejar -body { + http::cookiejar +} -returnCodes error -result {wrong # args: should be "http::cookiejar method ?arg ...?"} +test http-cookiejar-2.2 {cookie storage: basics} -constraints cookiejar -body { + http::cookiejar ? +} -returnCodes error -result {unknown method "?": must be create, destroy, loglevel or new} +test http-cookiejar-2.3 {cookie storage: basics} -constraints cookiejar -body { + http::cookiejar loglevel +} -result info +test http-cookiejar-2.4 {cookie storage: basics} -constraints cookiejar -body { + http::cookiejar loglevel ? +} -returnCodes error -result {bad log level "?": must be debug, info, warn, or error} +test http-cookiejar-2.5 {cookie storage: basics} -constraints cookiejar -body { + http::cookiejar loglevel ? ? +} -returnCodes error -result {wrong # args: should be "http::cookiejar loglevel ?level?"} +test http-cookiejar-2.6 {cookie storage: basics} -setup { + set old [http::cookiejar loglevel] +} -constraints cookiejar -body { + list [http::cookiejar loglevel] [http::cookiejar loglevel debug] \ + [http::cookiejar loglevel] [http::cookiejar loglevel error] \ + [http::cookiejar loglevel] +} -cleanup { + http::cookiejar loglevel $old +} -result {info debug debug error error} +test http-cookiejar-2.7 {cookie storage: basics} -setup { + set old [http::cookiejar loglevel] +} -constraints cookiejar -body { + list [http::cookiejar loglevel] [http::cookiejar loglevel d] \ + [http::cookiejar loglevel i] [http::cookiejar loglevel w] \ + [http::cookiejar loglevel e] +} -cleanup { + http::cookiejar loglevel $old +} -result {info debug info warn error} + +test http-cookiejar-3.1 {cookie storage: class} cookiejar { + info object isa object http::cookiejar +} 1 +test http-cookiejar-3.2 {cookie storage: class} cookiejar { + info object isa class http::cookiejar +} 1 +test http-cookiejar-3.3 {cookie storage: class} cookiejar { + lsort [info object methods http::cookiejar] +} loglevel +test http-cookiejar-3.4 {cookie storage: class} cookiejar { + lsort [info object methods http::cookiejar -all] +} {create destroy loglevel new} +test http-cookiejar-3.5 {cookie storage: class} -setup { + catch {rename ::cookiejar ""} +} -constraints cookiejar -body { + namespace eval :: {http::cookiejar create cookiejar} +} -cleanup { + catch {rename ::cookiejar ""} +} -result ::cookiejar +test http-cookiejar-3.6 {cookie storage: class} -setup { + catch {rename ::cookiejar ""} +} -constraints cookiejar -body { + list [http::cookiejar create ::cookiejar] [info commands ::cookiejar] \ + [::cookiejar destroy] [info commands ::cookiejar] +} -cleanup { + catch {rename ::cookiejar ""} +} -result {::cookiejar ::cookiejar {} {}} +test http-cookiejar-3.7 {cookie storage: class} -setup { + catch {rename ::cookiejar ""} +} -constraints cookiejar -body { + http::cookiejar create ::cookiejar foo bar +} -returnCodes error -cleanup { + catch {rename ::cookiejar ""} +} -result {wrong # args: should be "http::cookiejar create ::cookiejar ?path?"} + +test http-cookiejar-4.1 {cookie storage} -setup { + http::cookiejar create ::cookiejar +} -constraints cookiejar -body { + cookiejar +} -returnCodes error -cleanup { + ::cookiejar destroy +} -result {wrong # args: should be "cookiejar method ?arg ...?"} +test http-cookiejar-4.2 {cookie storage} -setup { + http::cookiejar create ::cookiejar +} -constraints cookiejar -body { + cookiejar ? +} -returnCodes error -cleanup { + ::cookiejar destroy +} -result {unknown method "?": must be destroy, forceLoadDomainData, getCookies, lookup or storeCookie} +test http-cookiejar-4.3 {cookie storage} -setup { + http::cookiejar create ::cookiejar +} -constraints cookiejar -body { + lsort [info object methods cookiejar -all] +} -cleanup { + ::cookiejar destroy +} -result {destroy forceLoadDomainData getCookies lookup storeCookie} +test http-cookiejar-4.4 {cookie storage} -setup { + http::cookiejar create ::cookiejar +} -constraints cookiejar -body { + cookiejar getCookies +} -returnCodes error -cleanup { + ::cookiejar destroy +} -result {wrong # args: should be "cookiejar getCookies proto host path"} +test http-cookiejar-4.5 {cookie storage} -setup { + http::cookiejar create ::cookiejar +} -constraints cookiejar -body { + cookiejar getCookies http www.example.com / +} -cleanup { + ::cookiejar destroy +} -result {} +test http-cookiejar-4.6 {cookie storage} -setup { + http::cookiejar create ::cookiejar +} -constraints cookiejar -body { + cookiejar storeCookie +} -returnCodes error -cleanup { + ::cookiejar destroy +} -result {wrong # args: should be "cookiejar storeCookie name value options"} +test http-cookiejar-4.7 {cookie storage} -setup { + http::cookiejar create ::cookiejar +} -constraints cookiejar -body { + cookiejar storeCookie foo bar { + persistent 0 + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } +} -cleanup { + ::cookiejar destroy +} -result {} + +::tcltest::cleanupTests + +# Local variables: +# mode: tcl +# End: -- cgit v0.12 From a8069e81b796f9aeb06b21ceabf1ba9760eac3cf Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 24 Feb 2014 08:13:12 +0000 Subject: more functional testing --- tests/httpcookie.test | 166 ++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 166 insertions(+) diff --git a/tests/httpcookie.test b/tests/httpcookie.test index d2c4de8..6fd3073 100644 --- a/tests/httpcookie.test +++ b/tests/httpcookie.test @@ -149,6 +149,172 @@ test http-cookiejar-4.7 {cookie storage} -setup { } -cleanup { ::cookiejar destroy } -result {} +test http-cookiejar-4.8 {cookie storage} -setup { + http::cookiejar create ::cookiejar + oo::objdefine ::cookiejar export Database +} -constraints cookiejar -body { + cookiejar storeCookie foo bar { + persistent 0 + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } + # Poke inside implementation! + cookiejar Database eval {SELECT count(*) FROM sessionCookies} +} -cleanup { + ::cookiejar destroy +} -result 1 +test http-cookiejar-4.9 {cookie storage} -setup { + http::cookiejar create ::cookiejar + oo::objdefine ::cookiejar export Database +} -constraints cookiejar -body { + cookiejar storeCookie foo bar { + persistent 0 + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } + # Poke inside implementation! + cookiejar Database eval {SELECT count(*) FROM persistentCookies} +} -cleanup { + ::cookiejar destroy +} -result 0 +test http-cookiejar-4.10 {cookie storage} -setup { + http::cookiejar create ::cookiejar +} -constraints cookiejar -body { + cookiejar storeCookie foo bar [dict replace { + persistent 1 + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } expires [expr {[clock seconds]+5}]] +} -cleanup { + ::cookiejar destroy +} -result {} +test http-cookiejar-4.11 {cookie storage} -setup { + http::cookiejar create ::cookiejar + oo::objdefine ::cookiejar export Database +} -constraints cookiejar -body { + cookiejar storeCookie foo bar [dict replace { + persistent 1 + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } expires [expr {[clock seconds]+5}]] + # Poke inside implementation! + cookiejar Database eval {SELECT count(*) FROM sessionCookies} +} -cleanup { + ::cookiejar destroy +} -result 0 +test http-cookiejar-4.12 {cookie storage} -setup { + http::cookiejar create ::cookiejar + oo::objdefine ::cookiejar export Database +} -constraints cookiejar -body { + cookiejar storeCookie foo bar [dict replace { + persistent 1 + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } expires [expr {[clock seconds]+5}]] + # Poke inside implementation! + cookiejar Database eval {SELECT count(*) FROM persistentCookies} +} -cleanup { + ::cookiejar destroy +} -result 1 +test http-cookiejar-4.13 {cookie storage} -setup { + http::cookiejar create ::cookiejar + set result {} +} -constraints cookiejar -body { + lappend result [cookiejar getCookies http www.example.com /] + cookiejar storeCookie foo bar { + persistent 0 + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } + lappend result [cookiejar getCookies http www.example.com /] +} -cleanup { + ::cookiejar destroy +} -result {{} {foo bar}} +test http-cookiejar-4.14 {cookie storage} -setup { + http::cookiejar create ::cookiejar + set result {} +} -constraints cookiejar -body { + lappend result [cookiejar getCookies http www.example.com /] + cookiejar storeCookie foo bar [dict replace { + persistent 1 + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } expires [expr {[clock seconds]+5}]] + lappend result [cookiejar getCookies http www.example.com /] +} -cleanup { + ::cookiejar destroy +} -result {{} {foo bar}} +test http-cookiejar-4.15 {cookie storage} -setup { + http::cookiejar create ::cookiejar + set result {} +} -constraints cookiejar -body { + lappend result [cookiejar getCookies http www.example.com /] + cookiejar storeCookie foo bar { + persistent 0 + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } + cookiejar storeCookie foo bar [dict replace { + persistent 1 + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } expires [expr {[clock seconds]+5}]] + lappend result [cookiejar getCookies http www.example.com /] +} -cleanup { + ::cookiejar destroy +} -result {{} {foo bar}} +test http-cookiejar-4.16 {cookie storage} -setup { + http::cookiejar create ::cookiejar + set result {} +} -constraints cookiejar -body { + lappend result [cookiejar getCookies http www.example.com /] + cookiejar storeCookie foo1 bar { + persistent 0 + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } + cookiejar storeCookie foo2 bar [dict replace { + persistent 1 + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } expires [expr {[clock seconds]+5}]] + lappend result [lsort -stride 2 [cookiejar getCookies http www.example.com /]] +} -cleanup { + ::cookiejar destroy +} -result {{} {foo1 bar foo2 bar}} ::tcltest::cleanupTests -- cgit v0.12 From 403350cc99d91dbd8a8d77188b16cc9cbd866492 Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 25 Feb 2014 09:10:52 +0000 Subject: more tests and some fixes --- library/http/cookiejar.tcl | 33 +++++-- library/http/idna.tcl | 2 +- tests/http.test | 3 + tests/httpcookie.test | 213 +++++++++++++++++++++++++++++++++++++++++---- 4 files changed, 228 insertions(+), 23 deletions(-) diff --git a/library/http/cookiejar.tcl b/library/http/cookiejar.tcl index 3df52f0..e1d5fe4 100644 --- a/library/http/cookiejar.tcl +++ b/library/http/cookiejar.tcl @@ -234,12 +234,15 @@ package provide cookiejar $::http::cookiejar_version method InitDomainList {} { upvar 0 ::http::cookiejar_offline offline if {!$offline} { - set data [my GetDomainListOnline] - if {[string length $data]} { - my InstallDomainData $data - return + try { + set data [my GetDomainListOnline] + if {[string length $data]} { + my InstallDomainData $data + return + } + } on error {} { + log warn "attempting to fall back to built in version" } - log warn "attempting to fall back to built in version" } my InstallDomainData [my GetDomainListOffline] } @@ -317,8 +320,13 @@ package provide cookiejar $::http::cookiejar_version } destructor { - after cancel $aid - db close + catch { + after cancel $aid + } + catch { + db close + } + return } method GetCookiesForHostAndPath {listVar secure host path fullhost} { @@ -378,11 +386,22 @@ package provide cookiejar $::http::cookiejar_version 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 ($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} { diff --git a/library/http/idna.tcl b/library/http/idna.tcl index 7dfb968..53e45ca 100644 --- a/library/http/idna.tcl +++ b/library/http/idna.tcl @@ -25,7 +25,7 @@ namespace eval ::tcl::idna { # 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\u0100-\uffff]} $part ch]} { + if {[regexp {[^-A-Za-z0-9\u00a1-\uffff]} $part ch]} { scan $ch %c c if {$ch < "!" || $ch > "~"} { set ch [format "\\u%04x" $c] diff --git a/tests/http.test b/tests/http.test index 0f76258..0f1546f 100644 --- a/tests/http.test +++ b/tests/http.test @@ -1046,6 +1046,9 @@ test http-idna-4.9.1 {IDNA encoding: max lengths from RFC 5890} { dict get $opt -errorcode } {IDNA OVERLONG_PART xn--989aomsvi5e83db1d2a355cv1e0vak1dwrv93d5xbh15a0dt30a5jpsd879ccm6fea98c} unset overlong +test http-idna-4.10 {IDNA encoding: edge cases} { + ::tcl::idna encode pass\u00e9.example.com +} xn--pass-epa.example.com test http-idna-5.1 {IDNA decoding} { ::tcl::idna decode abc.def diff --git a/tests/httpcookie.test b/tests/httpcookie.test index 6fd3073..c0e7419 100644 --- a/tests/httpcookie.test +++ b/tests/httpcookie.test @@ -93,28 +93,28 @@ test http-cookiejar-3.7 {cookie storage: class} -setup { catch {rename ::cookiejar ""} } -result {wrong # args: should be "http::cookiejar create ::cookiejar ?path?"} -test http-cookiejar-4.1 {cookie storage} -setup { +test http-cookiejar-4.1 {cookie storage: instance} -setup { http::cookiejar create ::cookiejar } -constraints cookiejar -body { cookiejar } -returnCodes error -cleanup { ::cookiejar destroy } -result {wrong # args: should be "cookiejar method ?arg ...?"} -test http-cookiejar-4.2 {cookie storage} -setup { +test http-cookiejar-4.2 {cookie storage: instance} -setup { http::cookiejar create ::cookiejar } -constraints cookiejar -body { cookiejar ? } -returnCodes error -cleanup { ::cookiejar destroy } -result {unknown method "?": must be destroy, forceLoadDomainData, getCookies, lookup or storeCookie} -test http-cookiejar-4.3 {cookie storage} -setup { +test http-cookiejar-4.3 {cookie storage: instance} -setup { http::cookiejar create ::cookiejar } -constraints cookiejar -body { lsort [info object methods cookiejar -all] } -cleanup { ::cookiejar destroy } -result {destroy forceLoadDomainData getCookies lookup storeCookie} -test http-cookiejar-4.4 {cookie storage} -setup { +test http-cookiejar-4.4 {cookie storage: instance} -setup { http::cookiejar create ::cookiejar } -constraints cookiejar -body { cookiejar getCookies @@ -128,14 +128,14 @@ test http-cookiejar-4.5 {cookie storage} -setup { } -cleanup { ::cookiejar destroy } -result {} -test http-cookiejar-4.6 {cookie storage} -setup { +test http-cookiejar-4.6 {cookie storage: instance} -setup { http::cookiejar create ::cookiejar } -constraints cookiejar -body { cookiejar storeCookie } -returnCodes error -cleanup { ::cookiejar destroy } -result {wrong # args: should be "cookiejar storeCookie name value options"} -test http-cookiejar-4.7 {cookie storage} -setup { +test http-cookiejar-4.7 {cookie storage: instance} -setup { http::cookiejar create ::cookiejar } -constraints cookiejar -body { cookiejar storeCookie foo bar { @@ -149,7 +149,7 @@ test http-cookiejar-4.7 {cookie storage} -setup { } -cleanup { ::cookiejar destroy } -result {} -test http-cookiejar-4.8 {cookie storage} -setup { +test http-cookiejar-4.8 {cookie storage: instance} -setup { http::cookiejar create ::cookiejar oo::objdefine ::cookiejar export Database } -constraints cookiejar -body { @@ -166,7 +166,7 @@ test http-cookiejar-4.8 {cookie storage} -setup { } -cleanup { ::cookiejar destroy } -result 1 -test http-cookiejar-4.9 {cookie storage} -setup { +test http-cookiejar-4.9 {cookie storage: instance} -setup { http::cookiejar create ::cookiejar oo::objdefine ::cookiejar export Database } -constraints cookiejar -body { @@ -183,7 +183,7 @@ test http-cookiejar-4.9 {cookie storage} -setup { } -cleanup { ::cookiejar destroy } -result 0 -test http-cookiejar-4.10 {cookie storage} -setup { +test http-cookiejar-4.10 {cookie storage: instance} -setup { http::cookiejar create ::cookiejar } -constraints cookiejar -body { cookiejar storeCookie foo bar [dict replace { @@ -197,7 +197,7 @@ test http-cookiejar-4.10 {cookie storage} -setup { } -cleanup { ::cookiejar destroy } -result {} -test http-cookiejar-4.11 {cookie storage} -setup { +test http-cookiejar-4.11 {cookie storage: instance} -setup { http::cookiejar create ::cookiejar oo::objdefine ::cookiejar export Database } -constraints cookiejar -body { @@ -214,7 +214,7 @@ test http-cookiejar-4.11 {cookie storage} -setup { } -cleanup { ::cookiejar destroy } -result 0 -test http-cookiejar-4.12 {cookie storage} -setup { +test http-cookiejar-4.12 {cookie storage: instance} -setup { http::cookiejar create ::cookiejar oo::objdefine ::cookiejar export Database } -constraints cookiejar -body { @@ -231,7 +231,7 @@ test http-cookiejar-4.12 {cookie storage} -setup { } -cleanup { ::cookiejar destroy } -result 1 -test http-cookiejar-4.13 {cookie storage} -setup { +test http-cookiejar-4.13 {cookie storage: instance} -setup { http::cookiejar create ::cookiejar set result {} } -constraints cookiejar -body { @@ -248,7 +248,7 @@ test http-cookiejar-4.13 {cookie storage} -setup { } -cleanup { ::cookiejar destroy } -result {{} {foo bar}} -test http-cookiejar-4.14 {cookie storage} -setup { +test http-cookiejar-4.14 {cookie storage: instance} -setup { http::cookiejar create ::cookiejar set result {} } -constraints cookiejar -body { @@ -265,7 +265,7 @@ test http-cookiejar-4.14 {cookie storage} -setup { } -cleanup { ::cookiejar destroy } -result {{} {foo bar}} -test http-cookiejar-4.15 {cookie storage} -setup { +test http-cookiejar-4.15 {cookie storage: instance} -setup { http::cookiejar create ::cookiejar set result {} } -constraints cookiejar -body { @@ -290,7 +290,7 @@ test http-cookiejar-4.15 {cookie storage} -setup { } -cleanup { ::cookiejar destroy } -result {{} {foo bar}} -test http-cookiejar-4.16 {cookie storage} -setup { +test http-cookiejar-4.16 {cookie storage: instance} -setup { http::cookiejar create ::cookiejar set result {} } -constraints cookiejar -body { @@ -315,6 +315,189 @@ test http-cookiejar-4.16 {cookie storage} -setup { } -cleanup { ::cookiejar destroy } -result {{} {foo1 bar foo2 bar}} +test http-cookiejar-4.17 {cookie storage: instance} -setup { + http::cookiejar create ::cookiejar +} -constraints cookiejar -body { + cookiejar lookup a b c d +} -returnCodes error -cleanup { + ::cookiejar destroy +} -result {wrong # args: should be "cookiejar lookup ?host? ?key?"} +test http-cookiejar-4.18 {cookie storage: instance} -setup { + http::cookiejar create ::cookiejar + set result {} +} -constraints cookiejar -body { + lappend result [cookiejar lookup] + lappend result [cookiejar lookup www.example.com] + lappend result [catch {cookiejar lookup www.example.com foo} value] $value + cookiejar storeCookie foo bar { + persistent 0 + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } + lappend result [cookiejar lookup] + lappend result [cookiejar lookup www.example.com] + lappend result [cookiejar lookup www.example.com foo] +} -cleanup { + ::cookiejar destroy +} -result {{} {} 1 {no such key for that host} www.example.com foo bar} +test http-cookiejar-4.19 {cookie storage: instance} -setup { + http::cookiejar create ::cookiejar + set result {} +} -constraints cookiejar -body { + cookiejar storeCookie foo bar { + persistent 0 + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } + cookiejar storeCookie bar foo { + persistent 0 + secure 0 + domain www.example.org + origin www.example.org + path / + hostonly 1 + } + lappend result [lsort [cookiejar lookup]] + lappend result [cookiejar lookup www.example.com] + lappend result [cookiejar lookup www.example.com foo] + lappend result [cookiejar lookup www.example.org] + lappend result [cookiejar lookup www.example.org bar] +} -cleanup { + ::cookiejar destroy +} -result {{www.example.com www.example.org} foo bar bar foo} +test http-cookiejar-4.20 {cookie storage: instance} -setup { + http::cookiejar create ::cookiejar + set result {} +} -constraints cookiejar -body { + cookiejar storeCookie foo1 bar1 { + persistent 0 + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } + cookiejar storeCookie foo2 bar2 [dict replace { + persistent 1 + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } expires [expr {[clock seconds]+5}]] + lappend result [cookiejar lookup] + lappend result [lsort [cookiejar lookup www.example.com]] + lappend result [cookiejar lookup www.example.com foo1] + lappend result [cookiejar lookup www.example.com foo2] +} -cleanup { + ::cookiejar destroy +} -result {www.example.com {foo1 foo2} bar1 bar2} +test http-cookiejar-4.21 {cookie storage: instance} -setup { + http::cookiejar create ::cookiejar + set result {} +} -constraints cookiejar -body { + cookiejar storeCookie foo1 bar1 { + persistent 0 + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } + cookiejar storeCookie foo2 bar2 { + persistent 0 + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } + lappend result [cookiejar lookup] + lappend result [lsort [cookiejar lookup www.example.com]] + lappend result [cookiejar lookup www.example.com foo1] + lappend result [cookiejar lookup www.example.com foo2] +} -cleanup { + ::cookiejar destroy +} -result {www.example.com {foo1 foo2} bar1 bar2} +test http-cookiejar-4.22 {cookie storage: instance} -setup { + http::cookiejar create ::cookiejar + set result {} +} -constraints cookiejar -body { + cookiejar forceLoadDomainData x y z +} -returnCodes error -cleanup { + ::cookiejar destroy +} -result {wrong # args: should be "cookiejar forceLoadDomainData"} +test http-cookiejar-4.23 {cookie storage: instance} -setup { + http::cookiejar create ::cookiejar + set result {} +} -constraints cookiejar -body { + cookiejar forceLoadDomainData +} -cleanup { + ::cookiejar destroy +} -result {} + +test http-cookiejar-5.1 {cookie storage: constraints} -setup { + http::cookiejar create ::cookiejar +} -constraints cookiejar -body { + cookiejar forceLoadDomainData + cookiejar storeCookie foo bar { + persistent 0 + secure 0 + domain com + origin com + path / + hostonly 1 + } + cookiejar lookup +} -cleanup { + ::cookiejar destroy +} -result {} +test http-cookiejar-5.2 {cookie storage: constraints} -setup { + http::cookiejar create ::cookiejar +} -constraints cookiejar -body { + cookiejar forceLoadDomainData + cookiejar storeCookie foo bar { + persistent 0 + secure 0 + domain foo.example.com + origin bar.example.org + path / + hostonly 1 + } + cookiejar lookup +} -cleanup { + ::cookiejar destroy +} -result {} +test http-cookiejar-5.3 {cookie storage: constraints} -setup { + http::cookiejar create ::cookiejar +} -constraints cookiejar -body { + cookiejar forceLoadDomainData + cookiejar storeCookie foo1 bar { + persistent 0 + secure 0 + domain com + origin www.example.com + path / + hostonly 1 + } + cookiejar storeCookie foo2 bar { + persistent 0 + secure 0 + domain example.com + origin www.example.com + path / + hostonly 1 + } + cookiejar lookup +} -cleanup { + ::cookiejar destroy +} -result {example.com} ::tcltest::cleanupTests -- cgit v0.12 From b3e0829c502c2912317a0521963b481e3b982604 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 26 Feb 2014 08:58:05 +0000 Subject: start writing integration tests --- library/http/cookiejar.tcl | 38 ++++++++++++-------- tests/httpcookie.test | 86 ++++++++++++++++++++++++++++++++++++++++++++-- 2 files changed, 107 insertions(+), 17 deletions(-) diff --git a/library/http/cookiejar.tcl b/library/http/cookiejar.tcl index e1d5fe4..2b1f722 100644 --- a/library/http/cookiejar.tcl +++ b/library/http/cookiejar.tcl @@ -79,11 +79,12 @@ namespace eval ::http { 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} { + proc log {level msg args} { namespace upvar ::http cookiejar_loglevel loglevel set who [uplevel 1 self] 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}" } } @@ -185,7 +186,7 @@ package provide cookiejar $::http::cookiejar_version db eval { SELECT COUNT(*) AS cookieCount FROM persistentCookies } - log info "$storeorigin with $cookieCount entries" + log info "%s with %s entries" $storeorigin $cookieCount set aid [after $purgeinterval [namespace current]::my PurgeCookies] @@ -199,13 +200,14 @@ package provide cookiejar $::http::cookiejar_version method GetDomainListOnline {} { upvar 0 ::http::cookiejar_domainlist url - log debug "loading domain list from $url" + log debug "loading domain list from %s" $url set tok [::http::geturl $url] try { if {[::http::ncode $tok] == 200} { return [::http::data $tok] } else { - log error "failed to fetch list of forbidden cookie domains from ${url}: [::http::error $tok]" + log error "failed to fetch list of forbidden cookie domains from %s: %s" \ + $url [::http::error $tok] return {} } } finally { @@ -214,7 +216,7 @@ package provide cookiejar $::http::cookiejar_version } method GetDomainListOffline {} { upvar 0 ::http::cookiejar_domainfile filename - log debug "loading domain list from $filename" + log debug "loading domain list from %s" $filename try { set f [open $filename] try { @@ -227,7 +229,8 @@ package provide cookiejar $::http::cookiejar_version close $f } } on error {msg opt} { - log error "failed to read list of forbidden cookie domains from ${filename}: $msg" + log error "failed to read list of forbidden cookie domains from %s: %s" \ + $filename $msg return -options $opt $msg } } @@ -300,12 +303,13 @@ package provide cookiejar $::http::cookiejar_version } } if {$utf ne [::tcl::idna decode [string tolower $idna]]} { - log warn "mismatch in IDNA handling for $idna ($line, $utf, [::tcl::idna decode $idna])" + log warn "mismatch in IDNA handling for %s (%d, %s, %s)" \ + $idna $line $utf [::tcl::idna decode $idna] } } } set n [expr {[db total_changes] - $n}] - log debug "processed $n inserts generated from domain list" + log debug "processed %d inserts generated from domain list" $n } # This forces the rebuild of the domain data, loading it from @@ -331,7 +335,7 @@ package provide cookiejar $::http::cookiejar_version method GetCookiesForHostAndPath {listVar secure host path fullhost} { upvar 1 $listVar result - log debug "check for cookies for [locn $secure $host $path]" + log debug "check for cookies for %s" [locn $secure $host $path] db eval { SELECT key, value FROM persistentCookies WHERE domain = $host AND path = $path AND secure <= $secure @@ -391,7 +395,8 @@ package provide cookiejar $::http::cookiejar_version } dict with options {} if {$domain ne $origin} { - log debug "cookie domain varies from origin ($domain, $origin)" + log debug "cookie domain varies from origin (%s, %s)" \ + $domain $origin if {[string match .* $domain]} { set dotd $domain } else { @@ -445,7 +450,8 @@ package provide cookiejar $::http::cookiejar_version WHERE domain = $domain AND path = $path AND key = $name AND secure <= $secure } incr deletions [db changes] - log debug "defined session cookie for [locn $secure $domain $path $name]" + log debug "defined session cookie for %s" \ + [locn $secure $domain $path $name] } elseif {$expires < $now} { db eval { DELETE FROM persistentCookies @@ -459,7 +465,8 @@ package provide cookiejar $::http::cookiejar_version AND secure <= $secure; } incr deletions [incr del [db changes]] - log debug "deleted $del cookies for [locn $secure $domain $path $name]" + log debug "deleted %d cookies for %s" \ + $del [locn $secure $domain $path $name] } else { db eval { INSERT OR REPLACE INTO persistentCookies ( @@ -469,7 +476,9 @@ package provide cookiejar $::http::cookiejar_version WHERE domain = $domain AND path = $path AND key = $name AND secure <= $secure } incr deletions [db changes] - log debug "defined persistent cookie for [locn $secure $domain $path $name], expires at [clock format $expires]" + log debug "defined persistent cookie for %s, expires at %s" \ + [locn $secure $domain $path $name] \ + [clock format $expires] } } } @@ -478,9 +487,10 @@ package provide cookiejar $::http::cookiejar_version namespace upvar ::http \ cookiejar_vacuumtrigger trigger \ cookiejar_purgeinterval interval + catch {after cancel $aid} set aid [after $interval [namespace current]::my PurgeCookies] set now [clock seconds] - log debug "purging cookies that expired before [clock format $now]" + log debug "purging cookies that expired before %s" [clock format $now] db transaction { db eval { DELETE FROM persistentCookies WHERE expiry < $now diff --git a/tests/httpcookie.test b/tests/httpcookie.test index c0e7419..1733fd4 100644 --- a/tests/httpcookie.test +++ b/tests/httpcookie.test @@ -444,8 +444,8 @@ test http-cookiejar-4.23 {cookie storage: instance} -setup { test http-cookiejar-5.1 {cookie storage: constraints} -setup { http::cookiejar create ::cookiejar -} -constraints cookiejar -body { cookiejar forceLoadDomainData +} -constraints cookiejar -body { cookiejar storeCookie foo bar { persistent 0 secure 0 @@ -460,8 +460,8 @@ test http-cookiejar-5.1 {cookie storage: constraints} -setup { } -result {} test http-cookiejar-5.2 {cookie storage: constraints} -setup { http::cookiejar create ::cookiejar -} -constraints cookiejar -body { cookiejar forceLoadDomainData +} -constraints cookiejar -body { cookiejar storeCookie foo bar { persistent 0 secure 0 @@ -476,8 +476,8 @@ test http-cookiejar-5.2 {cookie storage: constraints} -setup { } -result {} test http-cookiejar-5.3 {cookie storage: constraints} -setup { http::cookiejar create ::cookiejar -} -constraints cookiejar -body { cookiejar forceLoadDomainData +} -constraints cookiejar -body { cookiejar storeCookie foo1 bar { persistent 0 secure 0 @@ -498,6 +498,86 @@ test http-cookiejar-5.3 {cookie storage: constraints} -setup { } -cleanup { ::cookiejar destroy } -result {example.com} +test http-cookiejar-5.4 {cookie storage: constraints} -setup { + http::cookiejar create ::cookiejar + cookiejar forceLoadDomainData +} -constraints cookiejar -body { + cookiejar storeCookie foo bar1 { + persistent 0 + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } + cookiejar storeCookie foo bar2 { + persistent 0 + secure 0 + domain example.com + origin www.example.com + path / + hostonly 1 + } + lsort [cookiejar lookup] +} -cleanup { + ::cookiejar destroy +} -result {example.com www.example.com} + +test http-cookiejar-6.1 {cookie storage: expiry and lookup} -setup { + http::cookiejar create ::cookiejar + oo::objdefine cookiejar export PurgeCookies + set result {} + proc values cookies { + global result + lappend result [lsort [lmap {k v} $cookies {set v}]] + } +} -constraints cookiejar -body { + values [cookiejar getCookies http www.example.com /] + cookiejar storeCookie foo session { + persistent 0 + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } + values [cookiejar getCookies http www.example.com /] + cookiejar storeCookie foo cookie [dict replace { + persistent 1 + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } expires [expr {[clock seconds]+1}]] + values [cookiejar getCookies http www.example.com /] + cookiejar storeCookie foo session-global { + persistent 0 + secure 0 + domain example.com + origin www.example.com + path / + hostonly 0 + } + values [cookiejar getCookies http www.example.com /] + after 2500 + update + values [cookiejar getCookies http www.example.com /] + cookiejar PurgeCookies + values [cookiejar getCookies http www.example.com /] + cookiejar storeCookie foo go-away { + persistent 1 + secure 0 + domain example.com + origin www.example.com + path / + hostonly 0 + expires 0 + } + values [cookiejar getCookies http www.example.com /] +} -cleanup { + ::cookiejar destroy +} -result {{} session cookie {cookie session-global} {cookie session-global} session-global {}} ::tcltest::cleanupTests -- cgit v0.12 From 1575eb36c1ca196aefccf4813d1767c439dccb1f Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 3 Mar 2014 23:22:12 +0000 Subject: working towards a more consistent way of handling options in the cookiejar API --- library/http/cookiejar.tcl | 57 ++++++++++----- library/http/http.tcl | 11 ++- tests/httpcookie.test | 168 ++++++++++++++++++++++++++++----------------- 3 files changed, 149 insertions(+), 87 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 -- diff --git a/tests/httpcookie.test b/tests/httpcookie.test index 1733fd4..3ea4d55 100644 --- a/tests/httpcookie.test +++ b/tests/httpcookie.test @@ -29,7 +29,7 @@ test http-cookiejar-2.1 {cookie storage: basics} -constraints cookiejar -body { } -returnCodes error -result {wrong # args: should be "http::cookiejar method ?arg ...?"} test http-cookiejar-2.2 {cookie storage: basics} -constraints cookiejar -body { http::cookiejar ? -} -returnCodes error -result {unknown method "?": must be create, destroy, loglevel or new} +} -returnCodes error -result {unknown method "?": must be configure, create, destroy, loglevel or new} test http-cookiejar-2.3 {cookie storage: basics} -constraints cookiejar -body { http::cookiejar loglevel } -result info @@ -66,10 +66,10 @@ test http-cookiejar-3.2 {cookie storage: class} cookiejar { } 1 test http-cookiejar-3.3 {cookie storage: class} cookiejar { lsort [info object methods http::cookiejar] -} loglevel +} {configure loglevel} test http-cookiejar-3.4 {cookie storage: class} cookiejar { lsort [info object methods http::cookiejar -all] -} {create destroy loglevel new} +} {configure create destroy loglevel new} test http-cookiejar-3.5 {cookie storage: class} -setup { catch {rename ::cookiejar ""} } -constraints cookiejar -body { @@ -92,6 +92,21 @@ test http-cookiejar-3.7 {cookie storage: class} -setup { } -returnCodes error -cleanup { catch {rename ::cookiejar ""} } -result {wrong # args: should be "http::cookiejar create ::cookiejar ?path?"} +test http-cookiejar-3.8 {cookie storage: class} cookiejar { + http::cookiejar configure +} {-domainfile -domainlist -offline -purgeinterval -vacuumtrigger} +test http-cookiejar-3.9 {cookie storage: class} -constraints cookiejar -body { + http::cookiejar configure a b c d e +} -returnCodes error -result {wrong # args: should be "http::cookiejar configure ?optionName? ?optionValue?"} +test http-cookiejar-3.10 {cookie storage: class} -constraints cookiejar -body { + http::cookiejar configure a +} -returnCodes error -result {bad option "a": must be -domainfile, -domainlist, -offline, -purgeinterval, or -vacuumtrigger} +test http-cookiejar-3.11 {cookie storage: class} -constraints cookiejar -body { + http::cookiejar configure -d +} -returnCodes error -result {ambiguous option "-d": must be -domainfile, -domainlist, -offline, -purgeinterval, or -vacuumtrigger} +test http-cookiejar-3.12 {cookie storage: class} -constraints cookiejar -body { + http::cookiejar configure -off +} -match glob -result * test http-cookiejar-4.1 {cookie storage: instance} -setup { http::cookiejar create ::cookiejar @@ -134,12 +149,13 @@ test http-cookiejar-4.6 {cookie storage: instance} -setup { cookiejar storeCookie } -returnCodes error -cleanup { ::cookiejar destroy -} -result {wrong # args: should be "cookiejar storeCookie name value options"} +} -result {wrong # args: should be "cookiejar storeCookie options"} test http-cookiejar-4.7 {cookie storage: instance} -setup { http::cookiejar create ::cookiejar } -constraints cookiejar -body { - cookiejar storeCookie foo bar { - persistent 0 + cookiejar storeCookie { + key foo + value bar secure 0 domain www.example.com origin www.example.com @@ -153,8 +169,9 @@ test http-cookiejar-4.8 {cookie storage: instance} -setup { http::cookiejar create ::cookiejar oo::objdefine ::cookiejar export Database } -constraints cookiejar -body { - cookiejar storeCookie foo bar { - persistent 0 + cookiejar storeCookie { + key foo + value bar secure 0 domain www.example.com origin www.example.com @@ -170,8 +187,9 @@ test http-cookiejar-4.9 {cookie storage: instance} -setup { http::cookiejar create ::cookiejar oo::objdefine ::cookiejar export Database } -constraints cookiejar -body { - cookiejar storeCookie foo bar { - persistent 0 + cookiejar storeCookie { + key foo + value bar secure 0 domain www.example.com origin www.example.com @@ -186,8 +204,9 @@ test http-cookiejar-4.9 {cookie storage: instance} -setup { test http-cookiejar-4.10 {cookie storage: instance} -setup { http::cookiejar create ::cookiejar } -constraints cookiejar -body { - cookiejar storeCookie foo bar [dict replace { - persistent 1 + cookiejar storeCookie [dict replace { + key foo + value bar secure 0 domain www.example.com origin www.example.com @@ -201,8 +220,9 @@ test http-cookiejar-4.11 {cookie storage: instance} -setup { http::cookiejar create ::cookiejar oo::objdefine ::cookiejar export Database } -constraints cookiejar -body { - cookiejar storeCookie foo bar [dict replace { - persistent 1 + cookiejar storeCookie [dict replace { + key foo + value bar secure 0 domain www.example.com origin www.example.com @@ -218,8 +238,9 @@ test http-cookiejar-4.12 {cookie storage: instance} -setup { http::cookiejar create ::cookiejar oo::objdefine ::cookiejar export Database } -constraints cookiejar -body { - cookiejar storeCookie foo bar [dict replace { - persistent 1 + cookiejar storeCookie [dict replace { + key foo + value bar secure 0 domain www.example.com origin www.example.com @@ -236,8 +257,9 @@ test http-cookiejar-4.13 {cookie storage: instance} -setup { set result {} } -constraints cookiejar -body { lappend result [cookiejar getCookies http www.example.com /] - cookiejar storeCookie foo bar { - persistent 0 + cookiejar storeCookie { + key foo + value bar secure 0 domain www.example.com origin www.example.com @@ -253,8 +275,9 @@ test http-cookiejar-4.14 {cookie storage: instance} -setup { set result {} } -constraints cookiejar -body { lappend result [cookiejar getCookies http www.example.com /] - cookiejar storeCookie foo bar [dict replace { - persistent 1 + cookiejar storeCookie [dict replace { + key foo + value bar secure 0 domain www.example.com origin www.example.com @@ -270,16 +293,18 @@ test http-cookiejar-4.15 {cookie storage: instance} -setup { set result {} } -constraints cookiejar -body { lappend result [cookiejar getCookies http www.example.com /] - cookiejar storeCookie foo bar { - persistent 0 + cookiejar storeCookie { + key foo + value bar secure 0 domain www.example.com origin www.example.com path / hostonly 1 } - cookiejar storeCookie foo bar [dict replace { - persistent 1 + cookiejar storeCookie [dict replace { + key foo + value bar secure 0 domain www.example.com origin www.example.com @@ -295,16 +320,18 @@ test http-cookiejar-4.16 {cookie storage: instance} -setup { set result {} } -constraints cookiejar -body { lappend result [cookiejar getCookies http www.example.com /] - cookiejar storeCookie foo1 bar { - persistent 0 + cookiejar storeCookie { + key foo1 + value bar secure 0 domain www.example.com origin www.example.com path / hostonly 1 } - cookiejar storeCookie foo2 bar [dict replace { - persistent 1 + cookiejar storeCookie [dict replace { + key foo2 + value bar secure 0 domain www.example.com origin www.example.com @@ -329,8 +356,9 @@ test http-cookiejar-4.18 {cookie storage: instance} -setup { lappend result [cookiejar lookup] lappend result [cookiejar lookup www.example.com] lappend result [catch {cookiejar lookup www.example.com foo} value] $value - cookiejar storeCookie foo bar { - persistent 0 + cookiejar storeCookie { + key foo + value bar secure 0 domain www.example.com origin www.example.com @@ -347,16 +375,18 @@ test http-cookiejar-4.19 {cookie storage: instance} -setup { http::cookiejar create ::cookiejar set result {} } -constraints cookiejar -body { - cookiejar storeCookie foo bar { - persistent 0 + cookiejar storeCookie { + key foo + value bar secure 0 domain www.example.com origin www.example.com path / hostonly 1 } - cookiejar storeCookie bar foo { - persistent 0 + cookiejar storeCookie { + key bar + value foo secure 0 domain www.example.org origin www.example.org @@ -375,16 +405,18 @@ test http-cookiejar-4.20 {cookie storage: instance} -setup { http::cookiejar create ::cookiejar set result {} } -constraints cookiejar -body { - cookiejar storeCookie foo1 bar1 { - persistent 0 + cookiejar storeCookie { + key foo1 + value bar1 secure 0 domain www.example.com origin www.example.com path / hostonly 1 } - cookiejar storeCookie foo2 bar2 [dict replace { - persistent 1 + cookiejar storeCookie [dict replace { + key foo2 + value bar2 secure 0 domain www.example.com origin www.example.com @@ -402,16 +434,18 @@ test http-cookiejar-4.21 {cookie storage: instance} -setup { http::cookiejar create ::cookiejar set result {} } -constraints cookiejar -body { - cookiejar storeCookie foo1 bar1 { - persistent 0 + cookiejar storeCookie { + key foo1 + value bar1 secure 0 domain www.example.com origin www.example.com path / hostonly 1 } - cookiejar storeCookie foo2 bar2 { - persistent 0 + cookiejar storeCookie { + key foo2 + value bar2 secure 0 domain www.example.com origin www.example.com @@ -446,8 +480,9 @@ test http-cookiejar-5.1 {cookie storage: constraints} -setup { http::cookiejar create ::cookiejar cookiejar forceLoadDomainData } -constraints cookiejar -body { - cookiejar storeCookie foo bar { - persistent 0 + cookiejar storeCookie { + key foo + value bar secure 0 domain com origin com @@ -462,8 +497,9 @@ test http-cookiejar-5.2 {cookie storage: constraints} -setup { http::cookiejar create ::cookiejar cookiejar forceLoadDomainData } -constraints cookiejar -body { - cookiejar storeCookie foo bar { - persistent 0 + cookiejar storeCookie { + key foo + value bar secure 0 domain foo.example.com origin bar.example.org @@ -478,16 +514,18 @@ test http-cookiejar-5.3 {cookie storage: constraints} -setup { http::cookiejar create ::cookiejar cookiejar forceLoadDomainData } -constraints cookiejar -body { - cookiejar storeCookie foo1 bar { - persistent 0 + cookiejar storeCookie { + key foo1 + value bar secure 0 domain com origin www.example.com path / hostonly 1 } - cookiejar storeCookie foo2 bar { - persistent 0 + cookiejar storeCookie { + key foo2 + value bar secure 0 domain example.com origin www.example.com @@ -502,16 +540,18 @@ test http-cookiejar-5.4 {cookie storage: constraints} -setup { http::cookiejar create ::cookiejar cookiejar forceLoadDomainData } -constraints cookiejar -body { - cookiejar storeCookie foo bar1 { - persistent 0 + cookiejar storeCookie { + key foo + value bar1 secure 0 domain www.example.com origin www.example.com path / hostonly 1 } - cookiejar storeCookie foo bar2 { - persistent 0 + cookiejar storeCookie { + key foo + value bar2 secure 0 domain example.com origin www.example.com @@ -533,8 +573,9 @@ test http-cookiejar-6.1 {cookie storage: expiry and lookup} -setup { } } -constraints cookiejar -body { values [cookiejar getCookies http www.example.com /] - cookiejar storeCookie foo session { - persistent 0 + cookiejar storeCookie { + key foo + value session secure 0 domain www.example.com origin www.example.com @@ -542,8 +583,9 @@ test http-cookiejar-6.1 {cookie storage: expiry and lookup} -setup { hostonly 1 } values [cookiejar getCookies http www.example.com /] - cookiejar storeCookie foo cookie [dict replace { - persistent 1 + cookiejar storeCookie [dict replace { + key foo + value cookie secure 0 domain www.example.com origin www.example.com @@ -551,8 +593,9 @@ test http-cookiejar-6.1 {cookie storage: expiry and lookup} -setup { hostonly 1 } expires [expr {[clock seconds]+1}]] values [cookiejar getCookies http www.example.com /] - cookiejar storeCookie foo session-global { - persistent 0 + cookiejar storeCookie { + key foo + value session-global secure 0 domain example.com origin www.example.com @@ -565,8 +608,9 @@ test http-cookiejar-6.1 {cookie storage: expiry and lookup} -setup { values [cookiejar getCookies http www.example.com /] cookiejar PurgeCookies values [cookiejar getCookies http www.example.com /] - cookiejar storeCookie foo go-away { - persistent 1 + cookiejar storeCookie { + key foo + value go-away secure 0 domain example.com origin www.example.com -- cgit v0.12 From 9597c478f9a01087b8969f960e14adf9df328eeb Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 4 Mar 2014 08:11:02 +0000 Subject: safer setter mechanism --- library/http/cookiejar.tcl | 31 ++++++++++++++++++++++++------- tests/httpcookie.test | 21 +++++++++++++++++++++ 2 files changed, 45 insertions(+), 7 deletions(-) diff --git a/library/http/cookiejar.tcl b/library/http/cookiejar.tcl index f1a7f7a..5c25e28 100644 --- a/library/http/cookiejar.tcl +++ b/library/http/cookiejar.tcl @@ -39,6 +39,23 @@ namespace eval ::http { ::oo::class create cookiejar } + namespace eval [info object namespace cookiejar] { + proc setInt {*var val} { + upvar 1 ${*var} var + if {[catch {incr dummy $val} msg]} { + return -code error $msg + } + set var $val + } + proc setBool {*var val} { + upvar 1 ${*var} var + if {[catch {if {$val} {}} msg]} { + return -code error $msg + } + set var [expr {!!$val}] + } + } + # Some support procedures, none particularly useful in general namespace eval cookiejar_support { # Set up a logger if the http package isn't actually loaded yet. @@ -99,20 +116,20 @@ package provide cookiejar $::http::cookiejar_version ::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} + -domainfile {cookiejar_domainfile set} + -domainlist {cookiejar_domainlist set} + -offline {cookiejar_offline setBool} + -purgeinterval {cookiejar_purgeinterval setInt} + -vacuumtrigger {cookiejar_vacuumtrigger setInt} } 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 + lassign [dict get $tbl $opt] varname setter namespace upvar ::http $varname var if {$optionValue ne "\u0000\u0000"} { - set var $optionValue + $setter var $optionValue } return $var } diff --git a/tests/httpcookie.test b/tests/httpcookie.test index 3ea4d55..ba39c1c 100644 --- a/tests/httpcookie.test +++ b/tests/httpcookie.test @@ -107,6 +107,27 @@ test http-cookiejar-3.11 {cookie storage: class} -constraints cookiejar -body { test http-cookiejar-3.12 {cookie storage: class} -constraints cookiejar -body { http::cookiejar configure -off } -match glob -result * +test http-cookiejar-3.13 {cookie storage: class} -setup { + set oldval [http::cookiejar configure -offline] +} -constraints cookiejar -body { + http::cookiejar configure -offline true +} -cleanup { + catch {http::cookiejar configure -offline $oldval} +} -result 1 +test http-cookiejar-3.14 {cookie storage: class} -setup { + set oldval [http::cookiejar configure -offline] +} -constraints cookiejar -body { + http::cookiejar configure -offline nonbool +} -cleanup { + catch {http::cookiejar configure -offline $oldval} +} -returnCodes error -result {expected boolean value but got "nonbool"} +test http-cookiejar-3.15 {cookie storage: class} -setup { + set oldval [http::cookiejar configure -purgeinterval] +} -constraints cookiejar -body { + http::cookiejar configure -purge nonint +} -cleanup { + catch {http::cookiejar configure -purgeinterval $oldval} +} -returnCodes error -result {expected integer but got "nonint"} test http-cookiejar-4.1 {cookie storage: instance} -setup { http::cookiejar create ::cookiejar -- cgit v0.12 From 666e80e5bd56c2edbfb3560924cdf2a73170e485 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 5 Mar 2014 22:28:12 +0000 Subject: more checks of domain data loading --- library/http/cookiejar.tcl | 24 +++++++++++------- tests/httpcookie.test | 62 ++++++++++++++++++++++++++++++++++++++++------ 2 files changed, 69 insertions(+), 17 deletions(-) diff --git a/library/http/cookiejar.tcl b/library/http/cookiejar.tcl index 5c25e28..a4ee78a 100644 --- a/library/http/cookiejar.tcl +++ b/library/http/cookiejar.tcl @@ -25,7 +25,7 @@ namespace eval ::http { # TODO: is this the _right_ list of domains to use? Or is there an alias # for it that will persist longer? variable cookiejar_domainlist \ - http://mxr.mozilla.org/mozilla-central/source/netwerk/dns/effective_tld_names.dat?raw=1 + http://publicsuffix.org/list/effective_tld_names.dat variable cookiejar_domainfile \ [file join [file dirname [info script]] effective_tld_names.txt.gz] # The list is directed to from http://publicsuffix.org/list/ @@ -142,7 +142,7 @@ package provide cookiejar $::http::cookiejar_version return $loglevel } - variable aid deletions + variable purgeTimer deletions constructor {{path ""}} { namespace import ::http::cookiejar_support::* namespace upvar ::http cookiejar_purgeinterval purgeinterval @@ -194,6 +194,7 @@ package provide cookiejar $::http::cookiejar_version 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, path, key, value, originonly, secure, 1 AS persistent @@ -225,7 +226,7 @@ package provide cookiejar $::http::cookiejar_version } log info "%s with %s entries" $storeorigin $cookieCount - set aid [after $purgeinterval [namespace current]::my PurgeCookies] + my PostponePurge # TODO: domain list refresh policy if {$path ne "" && ![db exists { @@ -235,6 +236,12 @@ package provide cookiejar $::http::cookiejar_version } } + method PostponePurge {} { + namespace upvar ::http cookiejar_purgeinterval interval + catch {after cancel $purgeTimer} + set purgeTimer [after $interval [namespace code {my PurgeCookies}]] + } + method GetDomainListOnline {} { upvar 0 ::http::cookiejar_domainlist url log debug "loading domain list from %s" $url @@ -345,7 +352,7 @@ package provide cookiejar $::http::cookiejar_version } } set n [expr {[db total_changes] - $n}] - log debug "processed %d inserts generated from domain list" $n + log info "constructed domain info with %d entries" $n } # This forces the rebuild of the domain data, loading it from @@ -361,7 +368,7 @@ package provide cookiejar $::http::cookiejar_version destructor { catch { - after cancel $aid + after cancel $purgeTimer } catch { db close @@ -525,8 +532,7 @@ package provide cookiejar $::http::cookiejar_version namespace upvar ::http \ cookiejar_vacuumtrigger trigger \ cookiejar_purgeinterval interval - catch {after cancel $aid} - set aid [after $interval [namespace current]::my PurgeCookies] + my PostponePurge set now [clock seconds] log debug "purging cookies that expired before %s" [clock format $now] db transaction { @@ -534,9 +540,9 @@ package provide cookiejar $::http::cookiejar_version DELETE FROM persistentCookies WHERE expiry < $now } incr deletions [db changes] + ### TODO: Cap the total number of cookies and session cookies, + ### purging least frequently used } - ### TODO: Cap the total number of cookies and session cookies, - ### purging least frequently used # Once we've deleted a fair bit, vacuum the database. Must be done # outside a transaction. diff --git a/tests/httpcookie.test b/tests/httpcookie.test index ba39c1c..ceca43f 100644 --- a/tests/httpcookie.test +++ b/tests/httpcookie.test @@ -92,36 +92,64 @@ test http-cookiejar-3.7 {cookie storage: class} -setup { } -returnCodes error -cleanup { catch {rename ::cookiejar ""} } -result {wrong # args: should be "http::cookiejar create ::cookiejar ?path?"} -test http-cookiejar-3.8 {cookie storage: class} cookiejar { +test http-cookiejar-3.8 {cookie storage: class} -setup { + catch {rename ::cookiejar ""} + set f [makeFile "" cookiejar] + file delete $f +} -constraints cookiejar -body { + http::cookiejar create ::cookiejar $f +} -cleanup { + catch {rename ::cookiejar ""} + removeFile $f +} -result ::cookiejar +test http-cookiejar-3.9 {cookie storage: class} -setup { + catch {rename ::cookiejar ""} + set f [makeFile "bogus content for a database" cookiejar] +} -constraints cookiejar -body { + http::cookiejar create ::cookiejar $f +} -returnCodes error -cleanup { + catch {rename ::cookiejar ""} + removeFile $f +} -result {file is encrypted or is not a database} +test http-cookiejar-3.10 {cookie storage: class} -setup { + catch {rename ::cookiejar ""} + set dir [makeDirectory cookiejar] +} -constraints cookiejar -body { + http::cookiejar create ::cookiejar $dir +} -returnCodes error -cleanup { + catch {rename ::cookiejar ""} + removeDirectory $dir +} -result {unable to open database file} +test http-cookiejar-3.11 {cookie storage: class} cookiejar { http::cookiejar configure } {-domainfile -domainlist -offline -purgeinterval -vacuumtrigger} -test http-cookiejar-3.9 {cookie storage: class} -constraints cookiejar -body { +test http-cookiejar-3.12 {cookie storage: class} -constraints cookiejar -body { http::cookiejar configure a b c d e } -returnCodes error -result {wrong # args: should be "http::cookiejar configure ?optionName? ?optionValue?"} -test http-cookiejar-3.10 {cookie storage: class} -constraints cookiejar -body { +test http-cookiejar-3.13 {cookie storage: class} -constraints cookiejar -body { http::cookiejar configure a } -returnCodes error -result {bad option "a": must be -domainfile, -domainlist, -offline, -purgeinterval, or -vacuumtrigger} -test http-cookiejar-3.11 {cookie storage: class} -constraints cookiejar -body { +test http-cookiejar-3.14 {cookie storage: class} -constraints cookiejar -body { http::cookiejar configure -d } -returnCodes error -result {ambiguous option "-d": must be -domainfile, -domainlist, -offline, -purgeinterval, or -vacuumtrigger} -test http-cookiejar-3.12 {cookie storage: class} -constraints cookiejar -body { +test http-cookiejar-3.15 {cookie storage: class} -constraints cookiejar -body { http::cookiejar configure -off } -match glob -result * -test http-cookiejar-3.13 {cookie storage: class} -setup { +test http-cookiejar-3.16 {cookie storage: class} -setup { set oldval [http::cookiejar configure -offline] } -constraints cookiejar -body { http::cookiejar configure -offline true } -cleanup { catch {http::cookiejar configure -offline $oldval} } -result 1 -test http-cookiejar-3.14 {cookie storage: class} -setup { +test http-cookiejar-3.17 {cookie storage: class} -setup { set oldval [http::cookiejar configure -offline] } -constraints cookiejar -body { http::cookiejar configure -offline nonbool } -cleanup { catch {http::cookiejar configure -offline $oldval} } -returnCodes error -result {expected boolean value but got "nonbool"} -test http-cookiejar-3.15 {cookie storage: class} -setup { +test http-cookiejar-3.18 {cookie storage: class} -setup { set oldval [http::cookiejar configure -purgeinterval] } -constraints cookiejar -body { http::cookiejar configure -purge nonint @@ -496,6 +524,24 @@ test http-cookiejar-4.23 {cookie storage: instance} -setup { } -cleanup { ::cookiejar destroy } -result {} +test http-cookiejar-4.23.a {cookie storage: instance} -setup { + set off [http::cookiejar configure -offline] +} -constraints cookiejar -body { + http::cookiejar configure -offline 1 + [http::cookiejar create ::cookiejar] destroy +} -cleanup { + catch {::cookiejar destroy} + http::cookiejar configure -offline $off +} -result {} +test http-cookiejar-4.23.b {cookie storage: instance} -setup { + set off [http::cookiejar configure -offline] +} -constraints cookiejar -body { + http::cookiejar configure -offline 0 + [http::cookiejar create ::cookiejar] destroy +} -cleanup { + catch {::cookiejar destroy} + http::cookiejar configure -offline $off +} -result {} test http-cookiejar-5.1 {cookie storage: constraints} -setup { http::cookiejar create ::cookiejar -- cgit v0.12 From c60bcbe1737477923bc616621a61177b5121bcbc Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 10 Mar 2014 09:00:31 +0000 Subject: Reorganize log level management, start testing persistence, refactor code to not put so much in ::http namespace --- library/http/cookiejar.tcl | 149 +++++++++++++++++++++++--------------------- tests/httpcookie.test | 151 ++++++++++++++++++++++++++++----------------- 2 files changed, 173 insertions(+), 127 deletions(-) diff --git a/library/http/cookiejar.tcl b/library/http/cookiejar.tcl index a4ee78a..a0225cc 100644 --- a/library/http/cookiejar.tcl +++ b/library/http/cookiejar.tcl @@ -17,47 +17,52 @@ package require tcl::idna 1.0 # Configuration for the cookiejar package, plus basic support procedures. # -namespace eval ::http { +# 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 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 cookiejar_version 0.1 + variable version 0.1 # TODO: is this the _right_ list of domains to use? Or is there an alias # for it that will persist longer? - variable cookiejar_domainlist \ + variable domainlist \ http://publicsuffix.org/list/effective_tld_names.dat - variable cookiejar_domainfile \ + variable domainfile \ [file join [file dirname [info script]] effective_tld_names.txt.gz] # The list is directed to from http://publicsuffix.org/list/ - variable cookiejar_loglevel info - variable cookiejar_vacuumtrigger 200 - variable cookiejar_offline false - variable cookiejar_purgeinterval 60000 - - # This is the class that we are creating - if {![llength [info commands cookiejar]]} { - ::oo::class create cookiejar - } - - namespace eval [info object namespace cookiejar] { - proc setInt {*var val} { - upvar 1 ${*var} var - if {[catch {incr dummy $val} msg]} { - return -code error $msg - } - set var $val - } - proc setBool {*var val} { - upvar 1 ${*var} var - if {[catch {if {$val} {}} msg]} { - return -code error $msg - } - set var [expr {!!$val}] - } - } + variable loglevel info + variable vacuumtrigger 200 + variable offline false + variable purgeinterval 60000 + variable domaincache {} # Some support procedures, none particularly useful in general - namespace eval cookiejar_support { + 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 { @@ -97,55 +102,52 @@ namespace eval ::http { clock format $ts -format "%Y%m%dT%H%M%S.${ms}Z" -gmt 1 } proc log {level msg args} { - namespace upvar ::http cookiejar_loglevel loglevel - set who [uplevel 1 self] + 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 cookiejar($who) - $msg" + ::http::Log "[isoNow] $LVL $who $mth - $msg" } } } } # Now we have enough information to provide the package. -package provide cookiejar $::http::cookiejar_version +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 {cookiejar_domainfile set} - -domainlist {cookiejar_domainlist set} - -offline {cookiejar_offline setBool} - -purgeinterval {cookiejar_purgeinterval setInt} - -vacuumtrigger {cookiejar_vacuumtrigger setInt} - } - 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 setter - namespace upvar ::http $varname var - if {$optionValue ne "\u0000\u0000"} { - $setter var $optionValue - } - return $var - } - self method loglevel {{level "\u0000\u0000"}} { - namespace upvar ::http cookiejar_loglevel loglevel - if {$level ne "\u0000\u0000"} { - set loglevel [::tcl::prefix match -message "log level" \ - {debug info warn error} $level] + self { + method configure {{optionName "\u0000\u0000"} {optionValue "\u0000\u0000"}} { + set tbl { + -domainfile {domainfile set} + -domainlist {domainlist set} + -loglevel {loglevel setLog} + -offline {offline setBool} + -purgeinterval {purgeinterval setInt} + -vacuumtrigger {vacuumtrigger setInt} + } + 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 setter + namespace upvar [namespace current] $varname var + if {$optionValue ne "\u0000\u0000"} { + $setter var $optionValue + } + return $var } - return $loglevel } variable purgeTimer deletions constructor {{path ""}} { - namespace import ::http::cookiejar_support::* - namespace upvar ::http cookiejar_purgeinterval purgeinterval + namespace import [info object namespace [self class]]::support::* if {$path eq ""} { sqlite3 [namespace current]::db :memory: @@ -237,17 +239,25 @@ package provide cookiejar $::http::cookiejar_version } method PostponePurge {} { - namespace upvar ::http cookiejar_purgeinterval interval + namespace upvar [info object namespace [self class]] \ + purgeinterval interval catch {after cancel $purgeTimer} set purgeTimer [after $interval [namespace code {my PurgeCookies}]] } method GetDomainListOnline {} { - upvar 0 ::http::cookiejar_domainlist url + namespace upvar [info object namespace [self class]] \ + domainlist url domaincache cache + lassign $cache when what + if {$when > [clock seconds] - 3600} { + log debug "using cached value created at [clock format $when -format {%Y%m%dT%H%M%SZ} -gmt 1]" + return $what + } log debug "loading domain list from %s" $url set tok [::http::geturl $url] try { if {[::http::ncode $tok] == 200} { + set cache [list [clock seconds] [::http::data $tok]] return [::http::data $tok] } log error "failed to fetch list of forbidden cookie domains from %s: %s" \ @@ -258,7 +268,8 @@ package provide cookiejar $::http::cookiejar_version } } method GetDomainListOffline {} { - upvar 0 ::http::cookiejar_domainfile filename + namespace upvar [info object namespace [self class]] \ + domainfile filename log debug "loading domain list from %s" $filename try { set f [open $filename] @@ -278,7 +289,8 @@ package provide cookiejar $::http::cookiejar_version } } method InitDomainList {} { - upvar 0 ::http::cookiejar_offline offline + namespace upvar [info object namespace [self class]] \ + offline offline if {!$offline} { try { set data [my GetDomainListOnline] @@ -529,9 +541,8 @@ package provide cookiejar $::http::cookiejar_version } method PurgeCookies {} { - namespace upvar ::http \ - cookiejar_vacuumtrigger trigger \ - cookiejar_purgeinterval interval + namespace upvar [info object namespace [self class]] \ + vacuumtrigger trigger purgeinterval interval my PostponePurge set now [clock seconds] log debug "purging cookies that expired before %s" [clock format $now] diff --git a/tests/httpcookie.test b/tests/httpcookie.test index ceca43f..41ca07e 100644 --- a/tests/httpcookie.test +++ b/tests/httpcookie.test @@ -29,34 +29,65 @@ test http-cookiejar-2.1 {cookie storage: basics} -constraints cookiejar -body { } -returnCodes error -result {wrong # args: should be "http::cookiejar method ?arg ...?"} test http-cookiejar-2.2 {cookie storage: basics} -constraints cookiejar -body { http::cookiejar ? -} -returnCodes error -result {unknown method "?": must be configure, create, destroy, loglevel or new} -test http-cookiejar-2.3 {cookie storage: basics} -constraints cookiejar -body { - http::cookiejar loglevel -} -result info +} -returnCodes error -result {unknown method "?": must be configure, create, destroy or new} +test http-cookiejar-2.3 {cookie storage: basics} cookiejar { + http::cookiejar configure +} {-domainfile -domainlist -loglevel -offline -purgeinterval -vacuumtrigger} test http-cookiejar-2.4 {cookie storage: basics} -constraints cookiejar -body { - http::cookiejar loglevel ? -} -returnCodes error -result {bad log level "?": must be debug, info, warn, or error} + http::cookiejar configure a b c d e +} -returnCodes error -result {wrong # args: should be "http::cookiejar configure ?optionName? ?optionValue?"} test http-cookiejar-2.5 {cookie storage: basics} -constraints cookiejar -body { - http::cookiejar loglevel ? ? -} -returnCodes error -result {wrong # args: should be "http::cookiejar loglevel ?level?"} -test http-cookiejar-2.6 {cookie storage: basics} -setup { - set old [http::cookiejar loglevel] + http::cookiejar configure a +} -returnCodes error -result {bad option "a": must be -domainfile, -domainlist, -loglevel, -offline, -purgeinterval, or -vacuumtrigger} +test http-cookiejar-2.6 {cookie storage: basics} -constraints cookiejar -body { + http::cookiejar configure -d +} -returnCodes error -result {ambiguous option "-d": must be -domainfile, -domainlist, -loglevel, -offline, -purgeinterval, or -vacuumtrigger} +test http-cookiejar-2.7 {cookie storage: basics} -setup { + set old [http::cookiejar configure -loglevel] } -constraints cookiejar -body { - list [http::cookiejar loglevel] [http::cookiejar loglevel debug] \ - [http::cookiejar loglevel] [http::cookiejar loglevel error] \ - [http::cookiejar loglevel] + list [http::cookiejar configure -loglevel] \ + [http::cookiejar configure -loglevel debug] \ + [http::cookiejar configure -loglevel] \ + [http::cookiejar configure -loglevel error] \ + [http::cookiejar configure -loglevel] } -cleanup { - http::cookiejar loglevel $old + http::cookiejar configure -loglevel $old } -result {info debug debug error error} -test http-cookiejar-2.7 {cookie storage: basics} -setup { - set old [http::cookiejar loglevel] +test http-cookiejar-2.8 {cookie storage: basics} -setup { + set old [http::cookiejar configure -loglevel] } -constraints cookiejar -body { - list [http::cookiejar loglevel] [http::cookiejar loglevel d] \ - [http::cookiejar loglevel i] [http::cookiejar loglevel w] \ - [http::cookiejar loglevel e] + list [http::cookiejar configure -loglevel] \ + [http::cookiejar configure -loglevel d] \ + [http::cookiejar configure -loglevel i] \ + [http::cookiejar configure -loglevel w] \ + [http::cookiejar configure -loglevel e] } -cleanup { - http::cookiejar loglevel $old + http::cookiejar configure -loglevel $old } -result {info debug info warn error} +test http-cookiejar-2.9 {cookie storage: basics} -constraints cookiejar -body { + http::cookiejar configure -off +} -match glob -result * +test http-cookiejar-2.10 {cookie storage: basics} -setup { + set oldval [http::cookiejar configure -offline] +} -constraints cookiejar -body { + http::cookiejar configure -offline true +} -cleanup { + catch {http::cookiejar configure -offline $oldval} +} -result 1 +test http-cookiejar-2.11 {cookie storage: basics} -setup { + set oldval [http::cookiejar configure -offline] +} -constraints cookiejar -body { + http::cookiejar configure -offline nonbool +} -cleanup { + catch {http::cookiejar configure -offline $oldval} +} -returnCodes error -result {expected boolean value but got "nonbool"} +test http-cookiejar-2.12 {cookie storage: basics} -setup { + set oldval [http::cookiejar configure -purgeinterval] +} -constraints cookiejar -body { + http::cookiejar configure -purge nonint +} -cleanup { + catch {http::cookiejar configure -purgeinterval $oldval} +} -returnCodes error -result {expected integer but got "nonint"} test http-cookiejar-3.1 {cookie storage: class} cookiejar { info object isa object http::cookiejar @@ -66,10 +97,10 @@ test http-cookiejar-3.2 {cookie storage: class} cookiejar { } 1 test http-cookiejar-3.3 {cookie storage: class} cookiejar { lsort [info object methods http::cookiejar] -} {configure loglevel} +} {configure} test http-cookiejar-3.4 {cookie storage: class} cookiejar { lsort [info object methods http::cookiejar -all] -} {configure create destroy loglevel new} +} {configure create destroy new} test http-cookiejar-3.5 {cookie storage: class} -setup { catch {rename ::cookiejar ""} } -constraints cookiejar -body { @@ -120,42 +151,6 @@ test http-cookiejar-3.10 {cookie storage: class} -setup { catch {rename ::cookiejar ""} removeDirectory $dir } -result {unable to open database file} -test http-cookiejar-3.11 {cookie storage: class} cookiejar { - http::cookiejar configure -} {-domainfile -domainlist -offline -purgeinterval -vacuumtrigger} -test http-cookiejar-3.12 {cookie storage: class} -constraints cookiejar -body { - http::cookiejar configure a b c d e -} -returnCodes error -result {wrong # args: should be "http::cookiejar configure ?optionName? ?optionValue?"} -test http-cookiejar-3.13 {cookie storage: class} -constraints cookiejar -body { - http::cookiejar configure a -} -returnCodes error -result {bad option "a": must be -domainfile, -domainlist, -offline, -purgeinterval, or -vacuumtrigger} -test http-cookiejar-3.14 {cookie storage: class} -constraints cookiejar -body { - http::cookiejar configure -d -} -returnCodes error -result {ambiguous option "-d": must be -domainfile, -domainlist, -offline, -purgeinterval, or -vacuumtrigger} -test http-cookiejar-3.15 {cookie storage: class} -constraints cookiejar -body { - http::cookiejar configure -off -} -match glob -result * -test http-cookiejar-3.16 {cookie storage: class} -setup { - set oldval [http::cookiejar configure -offline] -} -constraints cookiejar -body { - http::cookiejar configure -offline true -} -cleanup { - catch {http::cookiejar configure -offline $oldval} -} -result 1 -test http-cookiejar-3.17 {cookie storage: class} -setup { - set oldval [http::cookiejar configure -offline] -} -constraints cookiejar -body { - http::cookiejar configure -offline nonbool -} -cleanup { - catch {http::cookiejar configure -offline $oldval} -} -returnCodes error -result {expected boolean value but got "nonbool"} -test http-cookiejar-3.18 {cookie storage: class} -setup { - set oldval [http::cookiejar configure -purgeinterval] -} -constraints cookiejar -body { - http::cookiejar configure -purge nonint -} -cleanup { - catch {http::cookiejar configure -purgeinterval $oldval} -} -returnCodes error -result {expected integer but got "nonint"} test http-cookiejar-4.1 {cookie storage: instance} -setup { http::cookiejar create ::cookiejar @@ -689,6 +684,46 @@ test http-cookiejar-6.1 {cookie storage: expiry and lookup} -setup { } -cleanup { ::cookiejar destroy } -result {{} session cookie {cookie session-global} {cookie session-global} session-global {}} + +test http-cookiejar-7.1 {cookie storage: persistence of persistent cookies} -setup { + catch {rename ::cookiejar ""} + set f [makeFile "" cookiejar] + file delete $f +} -constraints cookiejar -body { + http::cookiejar create ::cookiejar $f + ::cookiejar destroy + http::cookiejar create ::cookiejar $f +} -cleanup { + catch {rename ::cookiejar ""} + removeFile $f +} -result ::cookiejar +test http-cookiejar-7.2 {cookie storage: persistence of persistent cookies} -setup { + catch {rename ::cookiejar ""} + set f [makeFile "" cookiejar] + file delete $f + set result {} +} -constraints cookiejar -body { + http::cookiejar create ::cookiejar $f + cookiejar storeCookie [dict replace { + key foo + value cookie + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } expires [expr {[clock seconds]+1}]] + lappend result [::cookiejar getCookies http www.example.com /] + ::cookiejar destroy + http::cookiejar create ::cookiejar + lappend result [::cookiejar getCookies http www.example.com /] + ::cookiejar destroy + http::cookiejar create ::cookiejar $f + lappend result [::cookiejar getCookies http www.example.com /] +} -cleanup { + catch {rename ::cookiejar ""} + removeFile $f +} -result {{foo cookie} {} {foo cookie}} ::tcltest::cleanupTests -- cgit v0.12 From 4fb87dc8dec7a0e8d59a97e0e3f398ecc4cc6f46 Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 31 Mar 2014 08:08:01 +0000 Subject: Better cookie option parsing that doesn't throw away critical information. --- library/http/http.tcl | 52 +++++++++++++++++++++++++++------------------------ 1 file changed, 28 insertions(+), 24 deletions(-) diff --git a/library/http/http.tcl b/library/http/http.tcl index 8720be1..620ade2 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -1210,55 +1210,59 @@ proc http::ParseCookie {token value} { 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] { - switch -glob -nocase -- $opt { - Expires=* { - set opt [string range $opt 8 end] + foreach option [split [regsub -all {;\s+} $opts \u0000] \u0000] { + regexp {^(.*?)(?:=(.*))?$} $option -> optname optval + switch -exact -- [string tolower $optname] { + expires { if {[catch { #Sun, 06 Nov 1994 08:49:37 GMT dict set realopts expires \ - [clock scan $opt -format "%a, %d %b %Y %T %Z"] + [clock scan $optval -format "%a, %d %b %Y %T %Z"] }] && [catch { # Google does this one #Mon, 01-Jan-1990 00:00:00 GMT dict set realopts expires \ - [clock scan $opt -format "%a, %d-%b-%Y %T %Z"] + [clock scan $optval -format "%a, %d-%b-%Y %T %Z"] }] && [catch { # This is in the RFC, but it is also in the original # Netscape cookie spec, now online at: # #Sunday, 06-Nov-94 08:49:37 GMT dict set realopts expires \ - [clock scan $opt -format "%A, %d-%b-%y %T %Z"] + [clock scan $optval -format "%A, %d-%b-%y %T %Z"] }]} {catch { #Sun Nov 6 08:49:37 1994 dict set realopts expires \ - [clock scan $opt -gmt 1 -format "%a %b %d %T %Y"] + [clock scan $optval -gmt 1 -format "%a %b %d %T %Y"] }} } - Max-Age=* { + max-age { # Normalize - set opt [string range $opt 8 end] - if {[string is integer -strict $opt]} { - dict set realopts expires [expr {[clock seconds] + $opt}] + if {[string is integer -strict $optval]} { + dict set realopts expires [expr {[clock seconds] + $optval}] } } - Domain=* { - set opt [string trimleft [string range $opt 7 end] "."] - if {$opt ne "" && ![string match *. $opt]} { - dict set realopts domain $opt - dict set realopts hostonly 0 + domain { + # From the domain-matches definition [RFC 2109, section 2]: + # Host A's name domain-matches host B's if [...] + # A is a FQDN string and has the form NB, where N is a + # non-empty name string, B has the form .B', and B' is a + # FQDN string. (So, x.y.com domain-matches .y.com but + # not y.com.) + if {$optval ne "" && ![string match *. $optval]} { + dict set realopts domain [string trimleft $optval "."] + dict set realopts hostonly [expr { + ! [string match .* $optval] + }] } } - Path=* { - set opt [string range $opt 5 end] - if {![string match /* $opt]} { - set opt $state(path) + path { + if {[string match /* $optval]} { + dict set realopts path $optval } - dict set realopts path $opt } - Secure - HttpOnly { - dict set realopts [string tolower $opt] 1 + secure - httponly { + dict set realopts [string tolower $optname] 1 } } } -- cgit v0.12 From c7e456e77d93bb89039ff214903039dee34a4ceb Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 1 Apr 2014 08:18:41 +0000 Subject: Limit number of cookies stored, deleting least recently used ones. --- library/http/cookiejar.tcl | 48 +++++++++++++++++++++++++++++++++++----------- tests/httpcookie.test | 6 +++--- 2 files changed, 40 insertions(+), 14 deletions(-) diff --git a/library/http/cookiejar.tcl b/library/http/cookiejar.tcl index a0225cc..5a1ee2f 100644 --- a/library/http/cookiejar.tcl +++ b/library/http/cookiejar.tcl @@ -57,6 +57,7 @@ namespace eval [info object namespace ::http::cookiejar] { # 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 domaincache {} @@ -130,6 +131,7 @@ package provide cookiejar \ -loglevel {loglevel setLog} -offline {offline setBool} -purgeinterval {purgeinterval setInt} + -retain {retainlimit setInt} -vacuumtrigger {vacuumtrigger setInt} } if {$optionName eq "\u0000\u0000"} { @@ -171,6 +173,7 @@ package provide cookiejar \ 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); @@ -391,18 +394,24 @@ package provide cookiejar \ 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 { @@ -499,11 +508,13 @@ package provide cookiejar \ if {!$persistent} { db eval { INSERT OR REPLACE INTO sessionCookies ( - secure, domain, path, key, value, originonly, creation, lastuse) - VALUES ($secure, $domain, $path, $key, $value, $hostonly, $now, $now); + 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 secure <= $secure AND originonly = $hostonly } incr deletions [db changes] log debug "defined session cookie for %s" \ @@ -512,13 +523,13 @@ package provide cookiejar \ db eval { DELETE FROM persistentCookies WHERE domain = $domain AND path = $path AND key = $key - AND secure <= $secure; + 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 secure <= $secure AND originonly = $hostonly } incr deletions [incr del [db changes]] log debug "deleted %d cookies for %s" \ @@ -526,11 +537,13 @@ package provide cookiejar \ } else { db eval { INSERT OR REPLACE INTO persistentCookies ( - secure, domain, path, key, value, originonly, expiry, creation) - VALUES ($secure, $domain, $path, $key, $value, $hostonly, $expires, $now); + 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 secure <= $secure AND originonly = $hostonly } incr deletions [db changes] log debug "defined persistent cookie for %s, expires at %s" \ @@ -542,7 +555,8 @@ package provide cookiejar \ method PurgeCookies {} { namespace upvar [info object namespace [self class]] \ - vacuumtrigger trigger purgeinterval interval + vacuumtrigger trigger purgeinterval interval \ + retainlimit retain my PostponePurge set now [clock seconds] log debug "purging cookies that expired before %s" [clock format $now] @@ -551,8 +565,20 @@ package provide cookiejar \ DELETE FROM persistentCookies WHERE expiry < $now } incr deletions [db changes] - ### TODO: Cap the total number of cookies and session cookies, - ### purging least frequently used + db eval { + DELETE FROM persistentCookies WHERE id IN ( + SELECT id FROM persistentCookies ORDER BY lastuse + LIMIT MAX(0, ( + SELECT COUNT(*) FROM persistentCookies) - $retain)) + } + incr deletions [db changes] + db eval { + DELETE FROM sessionCookies WHERE id IN ( + SELECT id FROM sessionCookies ORDER BY lastuse + LIMIT MAX(0, ( + SELECT COUNT(*) FROM sessionCookies) - $retain)) + } + incr deletions [db changes] } # Once we've deleted a fair bit, vacuum the database. Must be done diff --git a/tests/httpcookie.test b/tests/httpcookie.test index 41ca07e..b57638d 100644 --- a/tests/httpcookie.test +++ b/tests/httpcookie.test @@ -32,16 +32,16 @@ test http-cookiejar-2.2 {cookie storage: basics} -constraints cookiejar -body { } -returnCodes error -result {unknown method "?": must be configure, create, destroy or new} test http-cookiejar-2.3 {cookie storage: basics} cookiejar { http::cookiejar configure -} {-domainfile -domainlist -loglevel -offline -purgeinterval -vacuumtrigger} +} {-domainfile -domainlist -loglevel -offline -purgeinterval -retain -vacuumtrigger} test http-cookiejar-2.4 {cookie storage: basics} -constraints cookiejar -body { http::cookiejar configure a b c d e } -returnCodes error -result {wrong # args: should be "http::cookiejar configure ?optionName? ?optionValue?"} test http-cookiejar-2.5 {cookie storage: basics} -constraints cookiejar -body { http::cookiejar configure a -} -returnCodes error -result {bad option "a": must be -domainfile, -domainlist, -loglevel, -offline, -purgeinterval, or -vacuumtrigger} +} -returnCodes error -result {bad option "a": must be -domainfile, -domainlist, -loglevel, -offline, -purgeinterval, -retain, or -vacuumtrigger} test http-cookiejar-2.6 {cookie storage: basics} -constraints cookiejar -body { http::cookiejar configure -d -} -returnCodes error -result {ambiguous option "-d": must be -domainfile, -domainlist, -loglevel, -offline, -purgeinterval, or -vacuumtrigger} +} -returnCodes error -result {ambiguous option "-d": must be -domainfile, -domainlist, -loglevel, -offline, -purgeinterval, -retain, or -vacuumtrigger} test http-cookiejar-2.7 {cookie storage: basics} -setup { set old [http::cookiejar configure -loglevel] } -constraints cookiejar -body { -- cgit v0.12 From 02e0c5c152d48bd9ee31664b92b0ff85b222667f Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 20 Apr 2014 15:28:24 +0000 Subject: more tinkering --- library/http/cookiejar.tcl | 323 +++++++++++++++++++++++++++++---------------- tests/httpcookie.test | 133 ++++++++++++++++++- 2 files changed, 333 insertions(+), 123 deletions(-) diff --git a/library/http/cookiejar.tcl b/library/http/cookiejar.tcl index 5a1ee2f..1fc1ffe 100644 --- a/library/http/cookiejar.tcl +++ b/library/http/cookiejar.tcl @@ -30,6 +30,14 @@ namespace eval [info object namespace ::http::cookiejar] { } 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]} { @@ -48,8 +56,6 @@ namespace eval [info object namespace ::http::cookiejar] { # Makefiles variable version 0.1 - # TODO: is this the _right_ list of domains to use? Or is there an alias - # for it that will persist longer? variable domainlist \ http://publicsuffix.org/list/effective_tld_names.dat variable domainfile \ @@ -60,6 +66,7 @@ namespace eval [info object namespace ::http::cookiejar] { variable retainlimit 100 variable offline false variable purgeinterval 60000 + variable refreshinterval 10000000 variable domaincache {} # Some support procedures, none particularly useful in general @@ -128,26 +135,41 @@ package provide cookiejar \ set tbl { -domainfile {domainfile set} -domainlist {domainlist set} + -domainrefresh {refreshinterval setInterval} -loglevel {loglevel setLog} -offline {offline setBool} - -purgeinterval {purgeinterval setInt} + -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] - lassign [dict get $tbl $opt] varname setter + 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 + {*}$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 + variable purgeTimer deletions refreshTimer constructor {{path ""}} { namespace import [info object namespace [self class]]::support::* @@ -161,83 +183,100 @@ package provide cookiejar \ } set deletions 0 - 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, path, key, value, originonly, secure, - 1 AS persistent - FROM persistentCookies - UNION - SELECT id, domain, path, key, value, originonly, 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); - } - - set cookieCount "no" - db eval { - SELECT COUNT(*) AS cookieCount FROM persistentCookies - } - log info "%s with %s entries" $storeorigin $cookieCount + 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); + } - my PostponePurge + set cookieCount "no" + db eval { + SELECT COUNT(*) AS cookieCount FROM persistentCookies + } + log info "%s with %s entries" $storeorigin $cookieCount - # TODO: domain list refresh policy - if {$path ne "" && ![db exists { - SELECT 1 FROM domains - }]} then { - my InitDomainList + 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 + } } } @@ -248,29 +287,67 @@ package provide cookiejar \ set purgeTimer [after $interval [namespace code {my PurgeCookies}]] } - method GetDomainListOnline {} { + 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 what + lassign $cache when data if {$when > [clock seconds] - 3600} { - log debug "using cached value created at [clock format $when -format {%Y%m%dT%H%M%SZ} -gmt 1]" - return $what + 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 - set tok [::http::geturl $url] try { - if {[::http::ncode $tok] == 200} { - set cache [list [clock seconds] [::http::data $tok]] - return [::http::data $tok] - } + 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 [::http::error $tok] + $url $msg return {} - } finally { - ::http::cleanup $tok } } - method GetDomainListOffline {} { + method GetDomainListOffline {metaVar} { + upvar 1 $metaVar meta namespace upvar [info object namespace [self class]] \ domainfile filename log debug "loading domain list from %s" $filename @@ -281,6 +358,7 @@ package provide cookiejar \ zlib push gunzip $f } fconfigure $f -encoding utf-8 + dict set meta retrievalDate [file mtime $filename] return [read $f] } finally { close $f @@ -296,19 +374,20 @@ package provide cookiejar \ offline offline if {!$offline} { try { - set data [my GetDomainListOnline] + set data [my GetDomainListOnline metadata] if {[string length $data]} { - my InstallDomainData $data + my InstallDomainData $data $metadata return } } on error {} { log warn "attempting to fall back to built in version" } } - my InstallDomainData [my GetDomainListOffline] + set data [my GetDomainListOffline metadata] + my InstallDomainData $data $metadata } - method InstallDomainData {data} { + method InstallDomainData {data meta} { set n [db total_changes] db transaction { foreach line [split $data "\n"] { @@ -365,6 +444,15 @@ package provide cookiejar \ $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 @@ -376,6 +464,9 @@ package provide cookiejar \ db eval { DELETE FROM domains; DELETE FROM forbiddenSuper; + INSERT OR REPLACE INTO domainCacheMetadata + (id, retrievalDate, installDate) + VALUES (1, -1, -1); } my InitDomainList } @@ -386,6 +477,9 @@ package provide cookiejar \ after cancel $purgeTimer } catch { + after cancel $refreshTimer + } + catch { db close } return @@ -423,7 +517,12 @@ package provide cookiejar \ method getCookies {proto host path} { set result {} set paths [splitPath $path] - set domains [splitDomain [string tolower [::tcl::idna encode $host]]] + 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). @@ -436,20 +535,13 @@ package provide cookiejar \ # do the splitting exactly right, and it's far easier to work with # strings in Tcl than in SQL. db transaction { - if {[regexp {[^0-9.]} $host]} { - foreach domain $domains { - foreach p $paths { - my GetCookiesForHostAndPath result $secure $domain $p $host - } - } - } else { - # Ugh, it's a numeric domain! Restrict it... + foreach domain $domains { foreach p $paths { - my GetCookiesForHostAndPath result $secure $host $p $host + my GetCookiesForHostAndPath result $secure $domain $p $host } } + return $result } - return $result } method BadDomain options { @@ -555,8 +647,7 @@ package provide cookiejar \ method PurgeCookies {} { namespace upvar [info object namespace [self class]] \ - vacuumtrigger trigger purgeinterval interval \ - retainlimit retain + vacuumtrigger trigger retainlimit retain my PostponePurge set now [clock seconds] log debug "purging cookies that expired before %s" [clock format $now] @@ -567,16 +658,14 @@ package provide cookiejar \ incr deletions [db changes] db eval { DELETE FROM persistentCookies WHERE id IN ( - SELECT id FROM persistentCookies ORDER BY lastuse - LIMIT MAX(0, ( - SELECT COUNT(*) FROM persistentCookies) - $retain)) + 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 MAX(0, ( - SELECT COUNT(*) FROM sessionCookies) - $retain)) + LIMIT -1 OFFSET $retain) } incr deletions [db changes] } diff --git a/tests/httpcookie.test b/tests/httpcookie.test index b57638d..204c263 100644 --- a/tests/httpcookie.test +++ b/tests/httpcookie.test @@ -32,16 +32,16 @@ test http-cookiejar-2.2 {cookie storage: basics} -constraints cookiejar -body { } -returnCodes error -result {unknown method "?": must be configure, create, destroy or new} test http-cookiejar-2.3 {cookie storage: basics} cookiejar { http::cookiejar configure -} {-domainfile -domainlist -loglevel -offline -purgeinterval -retain -vacuumtrigger} +} {-domainfile -domainlist -domainrefresh -loglevel -offline -purgeold -retain -vacuumtrigger} test http-cookiejar-2.4 {cookie storage: basics} -constraints cookiejar -body { http::cookiejar configure a b c d e } -returnCodes error -result {wrong # args: should be "http::cookiejar configure ?optionName? ?optionValue?"} test http-cookiejar-2.5 {cookie storage: basics} -constraints cookiejar -body { http::cookiejar configure a -} -returnCodes error -result {bad option "a": must be -domainfile, -domainlist, -loglevel, -offline, -purgeinterval, -retain, or -vacuumtrigger} +} -returnCodes error -result {bad option "a": must be -domainfile, -domainlist, -domainrefresh, -loglevel, -offline, -purgeold, -retain, or -vacuumtrigger} test http-cookiejar-2.6 {cookie storage: basics} -constraints cookiejar -body { http::cookiejar configure -d -} -returnCodes error -result {ambiguous option "-d": must be -domainfile, -domainlist, -loglevel, -offline, -purgeinterval, -retain, or -vacuumtrigger} +} -returnCodes error -result {ambiguous option "-d": must be -domainfile, -domainlist, -domainrefresh, -loglevel, -offline, -purgeold, -retain, or -vacuumtrigger} test http-cookiejar-2.7 {cookie storage: basics} -setup { set old [http::cookiejar configure -loglevel] } -constraints cookiejar -body { @@ -82,12 +82,41 @@ test http-cookiejar-2.11 {cookie storage: basics} -setup { catch {http::cookiejar configure -offline $oldval} } -returnCodes error -result {expected boolean value but got "nonbool"} test http-cookiejar-2.12 {cookie storage: basics} -setup { - set oldval [http::cookiejar configure -purgeinterval] + set oldval [http::cookiejar configure -purgeold] } -constraints cookiejar -body { http::cookiejar configure -purge nonint } -cleanup { - catch {http::cookiejar configure -purgeinterval $oldval} -} -returnCodes error -result {expected integer but got "nonint"} + catch {http::cookiejar configure -purgeold $oldval} +} -returnCodes error -result {expected positive integer but got "nonint"} +test http-cookiejar-2.13 {cookie storage: basics} -setup { + set oldval [http::cookiejar configure -domainrefresh] +} -constraints cookiejar -body { + http::cookiejar configure -domainref nonint +} -cleanup { + catch {http::cookiejar configure -domainrefresh $oldval} +} -returnCodes error -result {expected positive integer but got "nonint"} +test http-cookiejar-2.14 {cookie storage: basics} -setup { + set oldval [http::cookiejar configure -domainrefresh] +} -constraints cookiejar -body { + http::cookiejar configure -domainref -42 +} -cleanup { + catch {http::cookiejar configure -domainrefresh $oldval} +} -returnCodes error -result {expected positive integer but got "-42"} +test http-cookiejar-2.15 {cookie storage: basics} -setup { + set oldval [http::cookiejar configure -domainrefresh] + set result unset + set tracer [http::cookiejar create tracer] +} -constraints cookiejar -body { + oo::objdefine $tracer method PostponeRefresh {} { + set ::result set + next + } + http::cookiejar configure -domainref 12345 + return $result +} -cleanup { + $tracer destroy + catch {http::cookiejar configure -domainrefresh $oldval} +} -result set test http-cookiejar-3.1 {cookie storage: class} cookiejar { info object isa object http::cookiejar @@ -624,6 +653,98 @@ test http-cookiejar-5.4 {cookie storage: constraints} -setup { } -cleanup { ::cookiejar destroy } -result {example.com www.example.com} +test http-cookiejar-5.5 {cookie storage: constraints} -setup { + http::cookiejar create ::cookiejar + cookiejar forceLoadDomainData +} -constraints cookiejar -body { + cookiejar storeCookie { + key foo1 + value 1 + secure 0 + domain com + origin www.example.com + path / + hostonly 0 + } + cookiejar storeCookie { + key foo2 + value 2 + secure 0 + domain com + origin www.example.com + path / + hostonly 1 + } + cookiejar storeCookie { + key foo3 + value 3 + secure 0 + domain example.com + origin www.example.com + path / + hostonly 0 + } + cookiejar storeCookie { + key foo4 + value 4 + secure 0 + domain example.com + origin www.example.com + path / + hostonly 1 + } + cookiejar storeCookie { + key foo5 + value 5 + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 0 + } + cookiejar storeCookie { + key foo6 + value 6 + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } + cookiejar storeCookie { + key foo7 + value 7 + secure 1 + domain www.example.com + origin www.example.com + path / + hostonly 0 + } + cookiejar storeCookie { + key foo8 + value 8 + secure 1 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } + cookiejar storeCookie { + key foo9 + value 9 + secure 0 + domain sub.www.example.com + origin www.example.com + path / + hostonly 1 + } + list [cookiejar getCookies http www.example.com /] \ + [cookiejar getCookies http www2.example.com /] \ + [cookiejar getCookies https www.example.com /] \ + [cookiejar getCookies http sub.www.example.com /] +} -cleanup { + ::cookiejar destroy +} -result {{foo3 3 foo6 6} {foo3 3} {foo3 3 foo6 6 foo8 8} {foo3 3 foo5 5}} test http-cookiejar-6.1 {cookie storage: expiry and lookup} -setup { http::cookiejar create ::cookiejar -- cgit v0.12 From de712c24fb56e83b27e2b1e513d145ce8008fc6e Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 22 Mar 2016 23:45:12 +0000 Subject: First simple step implementing TIP 445. --- generic/tcl.decls | 8 ++++++++ generic/tclDecls.h | 5 +++++ generic/tclObj.c | 24 ++++++++++++++++++++++++ generic/tclStubInit.c | 1 + 4 files changed, 38 insertions(+) diff --git a/generic/tcl.decls b/generic/tcl.decls index 574b49b..707420d 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2326,6 +2326,14 @@ declare 630 { # ----- BASELINE -- FOR -- 8.6.0 ----- # +# TIP #445 + +declare 631 { + void Tcl_FreeIntRep(Tcl_Obj *objPtr) +} + +# ----- BASELINE -- FOR -- 8.7.0 ----- # + ############################################################################## # Define the platform specific public Tcl interface. These functions are only diff --git a/generic/tclDecls.h b/generic/tclDecls.h index b022d3c..4275b91 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1816,6 +1816,8 @@ EXTERN int Tcl_FSUnloadFile(Tcl_Interp *interp, EXTERN void Tcl_ZlibStreamSetCompressionDictionary( Tcl_ZlibStream zhandle, Tcl_Obj *compressionDictionaryObj); +/* 631 */ +EXTERN void Tcl_FreeIntRep(Tcl_Obj *objPtr); typedef struct { const struct TclPlatStubs *tclPlatStubs; @@ -2482,6 +2484,7 @@ typedef struct TclStubs { void * (*tcl_FindSymbol) (Tcl_Interp *interp, Tcl_LoadHandle handle, const char *symbol); /* 628 */ int (*tcl_FSUnloadFile) (Tcl_Interp *interp, Tcl_LoadHandle handlePtr); /* 629 */ void (*tcl_ZlibStreamSetCompressionDictionary) (Tcl_ZlibStream zhandle, Tcl_Obj *compressionDictionaryObj); /* 630 */ + void (*tcl_FreeIntRep) (Tcl_Obj *objPtr); /* 631 */ } TclStubs; extern const TclStubs *tclStubsPtr; @@ -3774,6 +3777,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_FSUnloadFile) /* 629 */ #define Tcl_ZlibStreamSetCompressionDictionary \ (tclStubsPtr->tcl_ZlibStreamSetCompressionDictionary) /* 630 */ +#define Tcl_FreeIntRep \ + (tclStubsPtr->tcl_FreeIntRep) /* 631 */ #endif /* defined(USE_TCL_STUBS) */ diff --git a/generic/tclObj.c b/generic/tclObj.c index c641152..b2b962c 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -1726,6 +1726,30 @@ Tcl_InvalidateStringRep( /* *---------------------------------------------------------------------- * + * Tcl_FreeIntRep -- + * + * This function is called to free an object's internal representation. + * + * Results: + * None. + * + * Side effects: + * Calls the freeIntRepProc of the current Tcl_ObjType, if any. + * Sets typePtr field to NULL. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_FreeIntRep( + Tcl_Obj *objPtr) /* Object whose internal rep should be freed. */ +{ + TclFreeIntRep(objPtr); +} + +/* + *---------------------------------------------------------------------- + * * Tcl_NewBooleanObj -- * * This function is normally called when not debugging: i.e., when diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 5b7a1cd..83dd9d6 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -1415,6 +1415,7 @@ const TclStubs tclStubs = { Tcl_FindSymbol, /* 628 */ Tcl_FSUnloadFile, /* 629 */ Tcl_ZlibStreamSetCompressionDictionary, /* 630 */ + Tcl_FreeIntRep, /* 631 */ }; /* !END!: Do not edit above this line. */ -- cgit v0.12 From 95de12dbb42d94ed5f716d91bb4500ba5ae08616 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 23 Mar 2016 04:31:24 +0000 Subject: Next step: new routine Tcl_InitStringRep() --- generic/tcl.decls | 4 ++- generic/tclDecls.h | 6 ++++ generic/tclObj.c | 80 +++++++++++++++++++++++++++++++++++++++++++++++++++ generic/tclStubInit.c | 1 + 4 files changed, 90 insertions(+), 1 deletion(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index 707420d..24484a5 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2327,10 +2327,12 @@ declare 630 { # ----- BASELINE -- FOR -- 8.6.0 ----- # # TIP #445 - declare 631 { void Tcl_FreeIntRep(Tcl_Obj *objPtr) } +declare 632 { + char *Tcl_InitStringRep(Tcl_Obj *objPtr, const char *bytes, int numBytes) +} # ----- BASELINE -- FOR -- 8.7.0 ----- # diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 4275b91..3e2ac18 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1818,6 +1818,9 @@ EXTERN void Tcl_ZlibStreamSetCompressionDictionary( Tcl_Obj *compressionDictionaryObj); /* 631 */ EXTERN void Tcl_FreeIntRep(Tcl_Obj *objPtr); +/* 632 */ +EXTERN char * Tcl_InitStringRep(Tcl_Obj *objPtr, const char *bytes, + int numBytes); typedef struct { const struct TclPlatStubs *tclPlatStubs; @@ -2485,6 +2488,7 @@ typedef struct TclStubs { int (*tcl_FSUnloadFile) (Tcl_Interp *interp, Tcl_LoadHandle handlePtr); /* 629 */ void (*tcl_ZlibStreamSetCompressionDictionary) (Tcl_ZlibStream zhandle, Tcl_Obj *compressionDictionaryObj); /* 630 */ void (*tcl_FreeIntRep) (Tcl_Obj *objPtr); /* 631 */ + char * (*tcl_InitStringRep) (Tcl_Obj *objPtr, const char *bytes, int numBytes); /* 632 */ } TclStubs; extern const TclStubs *tclStubsPtr; @@ -3779,6 +3783,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_ZlibStreamSetCompressionDictionary) /* 630 */ #define Tcl_FreeIntRep \ (tclStubsPtr->tcl_FreeIntRep) /* 631 */ +#define Tcl_InitStringRep \ + (tclStubsPtr->tcl_InitStringRep) /* 632 */ #endif /* defined(USE_TCL_STUBS) */ diff --git a/generic/tclObj.c b/generic/tclObj.c index b2b962c..7fe0293 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -17,6 +17,7 @@ #include "tclInt.h" #include "tommath.h" #include +#include /* * Table of all object types. @@ -1700,6 +1701,85 @@ Tcl_GetStringFromObj( /* *---------------------------------------------------------------------- * + * Tcl_InitStringRep -- + * + * This function is called in several configurations to provide all + * the tools needed to set an object's string representation. The + * function is determined by the arguments. + * + * (objPtr->bytes != NULL && bytes != NULL) || (numBytes < 0) + * Invalid call -- panic! + * + * objPtr->bytes == NULL && bytes == NULL && numBytes >= 0 + * Allocation only - allocate space for (numBytes+1) chars. + * store in objPtr->bytes and return. Also sets + * objPtr->length to 0 and objPtr->bytes[0] to NUL. + * + * objPtr->bytes == NULL && bytes != NULL && numBytes >= 0 + * Allocate and copy. bytes is assumed to point to chars to + * copy into the string rep. objPtr->length = numBytes. Allocate + * array of (numBytes + 1) chars. store in objPtr->bytes. Copy + * numBytes chars from bytes to objPtr->bytes; Set + * objPtr->bytes[numBytes] to NUL and return objPtr->bytes. + * Caller must guarantee there are numBytes chars at bytes to + * be copied. + * + * objPtr->bytes != NULL && bytes == NULL && numBytes >= 0 + * Truncate. Set objPtr->length to numBytes and + * objPr->bytes[numBytes] to NUL. Caller has to guarantee + * that a prior allocating call allocated enough bytes for + * this to be valid. Return objPtr->bytes. + * + * Caller is expected to ascertain that the bytes copied into + * the string rep make up complete valid UTF-8 characters. + * + * Results: + * A pointer to the string rep of objPtr. + * + * Side effects: + * As described above. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_InitStringRep( + Tcl_Obj *objPtr, /* Object whose string rep is to be set */ + const char *bytes, + int numBytes) +{ + assert(numBytes >= 0); + + assert(objPtr->bytes == NULL || bytes == NULL); + + /* Allocate */ + if (objPtr->bytes == NULL) { + /* Allocate only as empty - extend later if bytes copied */ + objPtr->length = 0; + if (numBytes) { + objPtr->bytes = (char *)ckalloc((unsigned)(numBytes+1)); + if (bytes) { + /* Copy */ + memcpy(objPtr->bytes, bytes, (unsigned) numBytes); + objPtr->length = numBytes; + } + } else { + objPtr->bytes = tclEmptyStringRep; + } + } else { + /* objPtr->bytes != NULL bytes == NULL - Truncate */ + objPtr->length = numBytes; + } + + /* Terminate */ + objPtr->bytes[objPtr->length] = '\0'; + + return objPtr->bytes; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_InvalidateStringRep -- * * This function is called to invalidate an object's string diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 83dd9d6..775d4ac 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -1416,6 +1416,7 @@ const TclStubs tclStubs = { Tcl_FSUnloadFile, /* 629 */ Tcl_ZlibStreamSetCompressionDictionary, /* 630 */ Tcl_FreeIntRep, /* 631 */ + Tcl_InitStringRep, /* 632 */ }; /* !END!: Do not edit above this line. */ -- cgit v0.12 From 37f5c2af038e71d1c88fe0fcb9d061b6c620dec0 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 23 Mar 2016 04:50:21 +0000 Subject: Make sure no path emerges to write on tclEmptyStringRep. --- generic/tclObj.c | 1 + 1 file changed, 1 insertion(+) diff --git a/generic/tclObj.c b/generic/tclObj.c index 7fe0293..4f7194b 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -1765,6 +1765,7 @@ Tcl_InitStringRep( } } else { objPtr->bytes = tclEmptyStringRep; + return NULL; } } else { /* objPtr->bytes != NULL bytes == NULL - Truncate */ -- cgit v0.12 From cae0944edaf0979a05c2dab80d18f6434b0b306e Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 23 Mar 2016 10:10:10 +0000 Subject: Release memory after truncation. --- generic/tclObj.c | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/generic/tclObj.c b/generic/tclObj.c index 4f7194b..72c2340 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -1769,6 +1769,11 @@ Tcl_InitStringRep( } } else { /* objPtr->bytes != NULL bytes == NULL - Truncate */ + assert(numBytes <= objPtr->length); + if (objPtr->length > numBytes) { + objPtr->bytes = (char *)ckrealloc(objPtr->bytes, + (unsigned)(numBytes+1)); + } objPtr->length = numBytes; } -- cgit v0.12 From 847f2ba0d5e6d3bdc2c069bb54dcea60f2174cd0 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 23 Mar 2016 14:10:39 +0000 Subject: Revise Tcl_InitStringRep(); numBytes is unsigned. Only truncation permitted. --- generic/tcl.decls | 3 ++- generic/tclDecls.h | 4 ++-- generic/tclObj.c | 23 ++++++++++++----------- 3 files changed, 16 insertions(+), 14 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index 24484a5..2bb49b9 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2331,7 +2331,8 @@ declare 631 { void Tcl_FreeIntRep(Tcl_Obj *objPtr) } declare 632 { - char *Tcl_InitStringRep(Tcl_Obj *objPtr, const char *bytes, int numBytes) + char *Tcl_InitStringRep(Tcl_Obj *objPtr, const char *bytes, + unsigned int numBytes) } # ----- BASELINE -- FOR -- 8.7.0 ----- # diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 3e2ac18..7114ad9 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1820,7 +1820,7 @@ EXTERN void Tcl_ZlibStreamSetCompressionDictionary( EXTERN void Tcl_FreeIntRep(Tcl_Obj *objPtr); /* 632 */ EXTERN char * Tcl_InitStringRep(Tcl_Obj *objPtr, const char *bytes, - int numBytes); + unsigned int numBytes); typedef struct { const struct TclPlatStubs *tclPlatStubs; @@ -2488,7 +2488,7 @@ typedef struct TclStubs { int (*tcl_FSUnloadFile) (Tcl_Interp *interp, Tcl_LoadHandle handlePtr); /* 629 */ void (*tcl_ZlibStreamSetCompressionDictionary) (Tcl_ZlibStream zhandle, Tcl_Obj *compressionDictionaryObj); /* 630 */ void (*tcl_FreeIntRep) (Tcl_Obj *objPtr); /* 631 */ - char * (*tcl_InitStringRep) (Tcl_Obj *objPtr, const char *bytes, int numBytes); /* 632 */ + char * (*tcl_InitStringRep) (Tcl_Obj *objPtr, const char *bytes, unsigned int numBytes); /* 632 */ } TclStubs; extern const TclStubs *tclStubsPtr; diff --git a/generic/tclObj.c b/generic/tclObj.c index 72c2340..3fb344e 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -1746,22 +1746,24 @@ char * Tcl_InitStringRep( Tcl_Obj *objPtr, /* Object whose string rep is to be set */ const char *bytes, - int numBytes) + unsigned int numBytes) { - assert(numBytes >= 0); - assert(objPtr->bytes == NULL || bytes == NULL); + if (numBytes > INT_MAX) { + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); + } + /* Allocate */ if (objPtr->bytes == NULL) { /* Allocate only as empty - extend later if bytes copied */ objPtr->length = 0; if (numBytes) { - objPtr->bytes = (char *)ckalloc((unsigned)(numBytes+1)); + objPtr->bytes = (char *)ckalloc(numBytes+1); if (bytes) { /* Copy */ - memcpy(objPtr->bytes, bytes, (unsigned) numBytes); - objPtr->length = numBytes; + memcpy(objPtr->bytes, bytes, numBytes); + objPtr->length = (int) numBytes; } } else { objPtr->bytes = tclEmptyStringRep; @@ -1769,12 +1771,11 @@ Tcl_InitStringRep( } } else { /* objPtr->bytes != NULL bytes == NULL - Truncate */ - assert(numBytes <= objPtr->length); - if (objPtr->length > numBytes) { - objPtr->bytes = (char *)ckrealloc(objPtr->bytes, - (unsigned)(numBytes+1)); + assert((int)numBytes <= objPtr->length); + if (objPtr->length > (int)numBytes) { + objPtr->bytes = (char *)ckrealloc(objPtr->bytes, numBytes+1); + objPtr->length = (int)numBytes; } - objPtr->length = numBytes; } /* Terminate */ -- cgit v0.12 From 422d353b0a2e391d172664cb529dc42ac783b708 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 23 Mar 2016 15:19:05 +0000 Subject: Tcl_InitStringRep() bug. Truncation assumed length == allocated. Wrong! Convert "bytearray" Tcl_ObjType to used new facilities. No longer directly refers to bytes or length fields, or any ckalloc of string rep. --- generic/tclBinary.c | 61 +++++++++++++++++++++++++---------------------------- generic/tclObj.c | 7 ++---- 2 files changed, 31 insertions(+), 37 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 981f174..7abb5c5 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -15,6 +15,7 @@ #include "tommath.h" #include +#include /* * The following constants are used by GetFormatSpec to indicate various @@ -195,9 +196,9 @@ const Tcl_ObjType tclByteArrayType = { */ typedef struct ByteArray { - int used; /* The number of bytes used in the byte + unsigned int used; /* The number of bytes used in the byte * array. */ - int allocated; /* The amount of space actually allocated + unsigned int allocated; /* The amount of space actually allocated * minus 1 byte. */ unsigned char bytes[1]; /* The array of bytes. The actual size of this * field depends on the 'allocated' field @@ -410,6 +411,10 @@ Tcl_SetByteArrayLength( int length) /* New length for internal byte array. */ { ByteArray *byteArrayPtr; + unsigned newLength; + + assert(length >= 0); + newLength = (unsigned int)length; if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_SetByteArrayLength"); @@ -419,13 +424,13 @@ Tcl_SetByteArrayLength( } byteArrayPtr = GET_BYTEARRAY(objPtr); - if (length > byteArrayPtr->allocated) { - byteArrayPtr = ckrealloc(byteArrayPtr, BYTEARRAY_SIZE(length)); - byteArrayPtr->allocated = length; + if (newLength > byteArrayPtr->allocated) { + byteArrayPtr = ckrealloc(byteArrayPtr, BYTEARRAY_SIZE(newLength)); + byteArrayPtr->allocated = newLength; SET_BYTEARRAY(objPtr, byteArrayPtr); } TclInvalidateStringRep(objPtr); - byteArrayPtr->used = length; + byteArrayPtr->used = newLength; return byteArrayPtr->bytes; } @@ -523,7 +528,7 @@ DupByteArrayInternalRep( Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ Tcl_Obj *copyPtr) /* Object with internal rep to set. */ { - int length; + unsigned int length; ByteArray *srcArrayPtr, *copyArrayPtr; srcArrayPtr = GET_BYTEARRAY(srcPtr); @@ -565,41 +570,32 @@ UpdateStringOfByteArray( Tcl_Obj *objPtr) /* ByteArray object whose string rep to * update. */ { - int i, length, size; - unsigned char *src; - char *dst; - ByteArray *byteArrayPtr; - - byteArrayPtr = GET_BYTEARRAY(objPtr); - src = byteArrayPtr->bytes; - length = byteArrayPtr->used; + ByteArray *byteArrayPtr = GET_BYTEARRAY(objPtr); + unsigned char *src = byteArrayPtr->bytes; + unsigned int i, length = byteArrayPtr->used; + unsigned int size = length; /* * How much space will string rep need? */ - size = length; - for (i = 0; i < length && size >= 0; i++) { + for (i = 0; i < length && size <= INT_MAX; i++) { if ((src[i] == 0) || (src[i] > 127)) { size++; } } - if (size < 0) { + if (size > INT_MAX) { Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } - dst = ckalloc(size + 1); - objPtr->bytes = dst; - objPtr->length = size; - if (size == length) { - memcpy(dst, src, (size_t) size); - dst[size] = '\0'; + (void) Tcl_InitStringRep(objPtr, (char *)src, size); } else { + char *dst = Tcl_InitStringRep(objPtr, NULL, size); for (i = 0; i < length; i++) { dst += Tcl_UniCharToUtf(src[i], dst); } - *dst = '\0'; + (void)Tcl_InitStringRep(objPtr, NULL, size); } } @@ -629,7 +625,7 @@ TclAppendBytesToByteArray( int len) { ByteArray *byteArrayPtr; - int needed; + unsigned int length, needed; if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object","TclAppendBytesToByteArray"); @@ -642,23 +638,24 @@ TclAppendBytesToByteArray( /* Append zero bytes is a no-op. */ return; } + length = (unsigned int)len; if (objPtr->typePtr != &tclByteArrayType) { SetByteArrayFromAny(NULL, objPtr); } byteArrayPtr = GET_BYTEARRAY(objPtr); - if (len > INT_MAX - byteArrayPtr->used) { + if (length > INT_MAX - byteArrayPtr->used) { Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } - needed = byteArrayPtr->used + len; + needed = byteArrayPtr->used + length; /* * If we need to, resize the allocated space in the byte array. */ if (needed > byteArrayPtr->allocated) { ByteArray *ptr = NULL; - int attempt; + unsigned int attempt; if (needed <= INT_MAX/2) { /* Try to allocate double the total space that is needed. */ @@ -668,7 +665,7 @@ TclAppendBytesToByteArray( if (ptr == NULL) { /* Try to allocate double the increment that is needed (plus). */ unsigned int limit = INT_MAX - needed; - unsigned int extra = len + TCL_MIN_GROWTH; + unsigned int extra = length + TCL_MIN_GROWTH; int growth = (int) ((extra > limit) ? limit : extra); attempt = needed + growth; @@ -685,9 +682,9 @@ TclAppendBytesToByteArray( } if (bytes) { - memcpy(byteArrayPtr->bytes + byteArrayPtr->used, bytes, len); + memcpy(byteArrayPtr->bytes + byteArrayPtr->used, bytes, length); } - byteArrayPtr->used += len; + byteArrayPtr->used += length; TclInvalidateStringRep(objPtr); } diff --git a/generic/tclObj.c b/generic/tclObj.c index 3fb344e..d1fde0e 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -1771,11 +1771,8 @@ Tcl_InitStringRep( } } else { /* objPtr->bytes != NULL bytes == NULL - Truncate */ - assert((int)numBytes <= objPtr->length); - if (objPtr->length > (int)numBytes) { - objPtr->bytes = (char *)ckrealloc(objPtr->bytes, numBytes+1); - objPtr->length = (int)numBytes; - } + objPtr->bytes = (char *)ckrealloc(objPtr->bytes, numBytes+1); + objPtr->length = (int)numBytes; } /* Terminate */ -- cgit v0.12 From c79a28077fd431a82b7f82e27b1c053fc7f81a94 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 23 Mar 2016 21:36:29 +0000 Subject: Convert "dict" Tcl_ObjType to use new routines. --- generic/tclDictObj.c | 27 +++++++++++++++------------ 1 file changed, 15 insertions(+), 12 deletions(-) diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index c8474e6..46fa623 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -513,8 +513,7 @@ UpdateStringOfDict( /* Handle empty list case first, simplifies what follows */ if (numElems == 0) { - dictPtr->bytes = tclEmptyStringRep; - dictPtr->length = 0; + Tcl_InitStringRep(dictPtr, NULL, 0); return; } @@ -560,9 +559,7 @@ UpdateStringOfDict( * Pass 2: copy into string rep buffer. */ - dictPtr->length = bytesNeeded - 1; - dictPtr->bytes = ckalloc(bytesNeeded); - dst = dictPtr->bytes; + dst = Tcl_InitStringRep(dictPtr, NULL, bytesNeeded - 1); for (i=0,cPtr=dict->entryChainHead; inextPtr) { flagPtr[i] |= ( i ? TCL_DONT_QUOTE_HASH : 0 ); keyPtr = Tcl_GetHashKey(&dict->table, &cPtr->entry); @@ -576,7 +573,7 @@ UpdateStringOfDict( dst += TclConvertElement(elem, length, dst, flagPtr[i+1]); *dst++ = ' '; } - dictPtr->bytes[dictPtr->length] = '\0'; + (void)Tcl_InitStringRep(dictPtr, NULL, bytesNeeded - 1); if (flagPtr != localFlags) { ckfree(flagPtr); @@ -675,10 +672,13 @@ SetDictFromAny( TclNewStringObj(keyPtr, elemStart, elemSize); } else { /* Avoid double copy */ + char *dst; + TclNewObj(keyPtr); - keyPtr->bytes = ckalloc((unsigned) elemSize + 1); - keyPtr->length = TclCopyAndCollapse(elemSize, elemStart, - keyPtr->bytes); + Tcl_InvalidateStringRep(keyPtr); + dst = Tcl_InitStringRep(keyPtr, NULL, elemSize); + (void)Tcl_InitStringRep(keyPtr, NULL, + TclCopyAndCollapse(elemSize, elemStart, dst)); } if (TclFindDictElement(interp, nextElem, (limit - nextElem), @@ -691,10 +691,13 @@ SetDictFromAny( TclNewStringObj(valuePtr, elemStart, elemSize); } else { /* Avoid double copy */ + char *dst; + TclNewObj(valuePtr); - valuePtr->bytes = ckalloc((unsigned) elemSize + 1); - valuePtr->length = TclCopyAndCollapse(elemSize, elemStart, - valuePtr->bytes); + Tcl_InvalidateStringRep(valuePtr); + dst = Tcl_InitStringRep(valuePtr, NULL, elemSize); + (void)Tcl_InitStringRep(valuePtr, NULL, + TclCopyAndCollapse(elemSize, elemStart, dst)); } /* Store key and value in the hash table we're building. */ -- cgit v0.12 From 0412f3af193e42847eea813ee1e7a73f33bb4df2 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 23 Mar 2016 21:50:15 +0000 Subject: Revise "ensembleCommand" Tcl_ObjType to use new routines. --- generic/tclEnsemble.c | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 986a553..2ef2861 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -2703,11 +2703,9 @@ StringOfEnsembleCmdRep( Tcl_Obj *objPtr) { EnsembleCmdRep *ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1; - int length = strlen(ensembleCmd->fullSubcmdName); - objPtr->length = length; - objPtr->bytes = ckalloc(length + 1); - memcpy(objPtr->bytes, ensembleCmd->fullSubcmdName, (unsigned) length+1); + Tcl_InitStringRep(objPtr, ensembleCmd->fullSubcmdName, + strlen(ensembleCmd->fullSubcmdName)); } /* -- cgit v0.12 From 80bc5b30c2abaeff82866adde88e8582f8950ac1 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 24 Mar 2016 01:50:58 +0000 Subject: Revise "osType" Tcl_ObjType to use new routine. --- macosx/tclMacOSXFCmd.c | 31 ++++++++++++++++--------------- 1 file changed, 16 insertions(+), 15 deletions(-) diff --git a/macosx/tclMacOSXFCmd.c b/macosx/tclMacOSXFCmd.c index 8ecfd0b..13a939f 100644 --- a/macosx/tclMacOSXFCmd.c +++ b/macosx/tclMacOSXFCmd.c @@ -692,24 +692,25 @@ UpdateStringOfOSType( register Tcl_Obj *objPtr) /* OSType object whose string rep to * update. */ { - char string[5]; + const int size = TCL_UTF_MAX * 4; + char *dst = Tcl_InitStringRep(objPtr, NULL, size); OSType osType = (OSType) objPtr->internalRep.longValue; - Tcl_DString ds; Tcl_Encoding encoding = Tcl_GetEncoding(NULL, "macRoman"); - unsigned len; - - string[0] = (char) (osType >> 24); - string[1] = (char) (osType >> 16); - string[2] = (char) (osType >> 8); - string[3] = (char) (osType); - string[4] = '\0'; - Tcl_ExternalToUtfDString(encoding, string, -1, &ds); - len = (unsigned) Tcl_DStringLength(&ds) + 1; - objPtr->bytes = ckalloc(len); - memcpy(objPtr->bytes, Tcl_DStringValue(&ds), len); - objPtr->length = Tcl_DStringLength(&ds); - Tcl_DStringFree(&ds); + char src[5]; + int written; + + src[0] = (char) (osType >> 24); + src[1] = (char) (osType >> 16); + src[2] = (char) (osType >> 8); + src[3] = (char) (osType); + src[4] = '\0'; + + Tcl_ExternalToUtf(NULL, encoding, src, -1, /* flags */ 0, + /* statePtr */ NULL, dst, size, /* srcReadPtr */ NULL, + /* dstWrotePtr */ &written, /* dstCharsPtr */ NULL); Tcl_FreeEncoding(encoding); + + (void)Tcl_InitStringRep(objPtr, NULL, written); } /* -- cgit v0.12 From dc0adeafb4cc6aa8cb93633fa770603a4a3de6ba Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 24 Mar 2016 12:51:49 +0000 Subject: Revised "end-offset" Tcl_ObjType to use new routine. --- generic/tclUtil.c | 15 +++++++-------- 1 file changed, 7 insertions(+), 8 deletions(-) diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 2b0fb72..1d5e8fe 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -3653,17 +3653,16 @@ static void UpdateStringOfEndOffset( register Tcl_Obj *objPtr) { - char buffer[TCL_INTEGER_SPACE + 5]; - register int len = 3; + char *dst = Tcl_InitStringRep(objPtr, NULL, TCL_INTEGER_SPACE + 5); + int len = 3; - memcpy(buffer, "end", 4); + memcpy(dst, "end", len); if (objPtr->internalRep.longValue != 0) { - buffer[len++] = '-'; - len += TclFormatInt(buffer+len, -(objPtr->internalRep.longValue)); + dst[len++] = '-'; + len += TclFormatInt(dst+len, -(objPtr->internalRep.longValue)); } - objPtr->bytes = ckalloc((unsigned) len+1); - memcpy(objPtr->bytes, buffer, (unsigned) len+1); - objPtr->length = len; + + (void) Tcl_InitStringRep(objPtr, NULL, len); } /* -- cgit v0.12 From e9a10d7cdae1257ea36691dba5b3000f11abcf5c Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 24 Mar 2016 12:59:06 +0000 Subject: stay out of internals when nice interfaces are available. --- generic/tclTest.c | 10 ++-------- 1 file changed, 2 insertions(+), 8 deletions(-) diff --git a/generic/tclTest.c b/generic/tclTest.c index 7c30d36..5bfa8f7 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -7012,17 +7012,11 @@ TestconcatobjCmd( list1Ptr = Tcl_NewStringObj("foo bar sum", -1); Tcl_ListObjLength(NULL, list1Ptr, &len); - if (list1Ptr->bytes != NULL) { - ckfree(list1Ptr->bytes); - list1Ptr->bytes = NULL; - } + Tcl_InvalidateStringrep(list1Ptr); list2Ptr = Tcl_NewStringObj("eeny meeny", -1); Tcl_ListObjLength(NULL, list2Ptr, &len); - if (list2Ptr->bytes != NULL) { - ckfree(list2Ptr->bytes); - list2Ptr->bytes = NULL; - } + Tcl_InvalidateStringrep(list2Ptr); /* * Verify that concat'ing a list obj with one or more empty strings does -- cgit v0.12 From f6b543ae9431387f8ea088cb545591b29ee30c90 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 24 Mar 2016 13:16:42 +0000 Subject: oops --- generic/tclOOMethod.c | 4 +--- generic/tclTest.c | 4 ++-- 2 files changed, 3 insertions(+), 5 deletions(-) diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index 34fa108..6c9a2eb 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -1540,9 +1540,7 @@ TclOOGetMethodBody( if (mPtr->typePtr == &procMethodType) { ProcedureMethod *pmPtr = mPtr->clientData; - if (pmPtr->procPtr->bodyPtr->bytes == NULL) { - (void) Tcl_GetString(pmPtr->procPtr->bodyPtr); - } + (void) TclGetString(pmPtr->procPtr->bodyPtr); return pmPtr->procPtr->bodyPtr; } return NULL; diff --git a/generic/tclTest.c b/generic/tclTest.c index 5bfa8f7..d96e356 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -7012,11 +7012,11 @@ TestconcatobjCmd( list1Ptr = Tcl_NewStringObj("foo bar sum", -1); Tcl_ListObjLength(NULL, list1Ptr, &len); - Tcl_InvalidateStringrep(list1Ptr); + Tcl_InvalidateStringRep(list1Ptr); list2Ptr = Tcl_NewStringObj("eeny meeny", -1); Tcl_ListObjLength(NULL, list2Ptr, &len); - Tcl_InvalidateStringrep(list2Ptr); + Tcl_InvalidateStringRep(list2Ptr); /* * Verify that concat'ing a list obj with one or more empty strings does -- cgit v0.12 From 83ac8470a00b857bd74ea2071d5aa77e6de4d00b Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 24 Mar 2016 13:50:59 +0000 Subject: TclInitStringRep() already knows about tclEmptyStringRep. --- generic/tclObj.c | 2 +- generic/tclStringObj.c | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclObj.c b/generic/tclObj.c index d1fde0e..52be4cc 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -3505,7 +3505,7 @@ GetBignumFromObj( objPtr->internalRep.twoPtrValue.ptr2 = NULL; objPtr->typePtr = NULL; if (objPtr->bytes == NULL) { - TclInitStringRep(objPtr, tclEmptyStringRep, 0); + TclInitStringRep(objPtr, NULL, 0); } } return TCL_OK; diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 11a57e9..f867b76 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -3026,7 +3026,7 @@ UpdateStringOfString( String *stringPtr = GET_STRING(objPtr); if (stringPtr->numChars == 0) { - TclInitStringRep(objPtr, tclEmptyStringRep, 0); + TclInitStringRep(objPtr, NULL, 0); } else { (void) ExtendStringRepWithUnicode(objPtr, stringPtr->unicode, stringPtr->numChars); -- cgit v0.12 From 325b2f4adeef8a56f6c4cf0a758e809c544cdd90 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 24 Mar 2016 14:40:35 +0000 Subject: Update more Tcl_ObjTypes to use Tcl_InitStringRep(). Adapt TclInitStringRep macro to accept TclInitStringRep(objptr, NULL, 0) without warning -- requires outwitting compiler. --- generic/tclInt.h | 2 +- generic/tclObj.c | 59 ++++++++++++++++++++++++-------------------------------- 2 files changed, 26 insertions(+), 35 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index 42c13dd..462e1e0 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4206,7 +4206,7 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, (objPtr)->length = 0; \ } else { \ (objPtr)->bytes = (char *) ckalloc((unsigned) ((len) + 1)); \ - memcpy((objPtr)->bytes, (bytePtr), (unsigned) (len)); \ + memcpy((objPtr)->bytes, (bytePtr) ? (bytePtr) : tclEmptyStringRep, (unsigned) (len)); \ (objPtr)->bytes[len] = '\0'; \ (objPtr)->length = (len); \ } diff --git a/generic/tclObj.c b/generic/tclObj.c index 52be4cc..aa81588 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -1062,9 +1062,8 @@ TclDbInitNewObj( * debugging. */ { objPtr->refCount = 0; - objPtr->bytes = tclEmptyStringRep; - objPtr->length = 0; objPtr->typePtr = NULL; + TclInitStringRep(objPtr, NULL, 0); #ifdef TCL_THREADS /* @@ -1917,6 +1916,7 @@ Tcl_DbNewBooleanObj( register Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); + /* Optimized TclInvalidateStringRep() */ objPtr->bytes = NULL; objPtr->internalRep.longValue = (boolValue? 1 : 0); @@ -2309,6 +2309,7 @@ Tcl_DbNewDoubleObj( register Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); + /* Optimized TclInvalidateStringRep() */ objPtr->bytes = NULL; objPtr->internalRep.doubleValue = dblValue; @@ -2475,15 +2476,10 @@ static void UpdateStringOfDouble( register Tcl_Obj *objPtr) /* Double obj with string rep to update. */ { - char buffer[TCL_DOUBLE_SPACE]; - register int len; + char *dst = Tcl_InitStringRep(objPtr, NULL, TCL_DOUBLE_SPACE); - Tcl_PrintDouble(NULL, objPtr->internalRep.doubleValue, buffer); - len = strlen(buffer); - - objPtr->bytes = ckalloc(len + 1); - memcpy(objPtr->bytes, buffer, (unsigned) len + 1); - objPtr->length = len; + Tcl_PrintDouble(NULL, objPtr->internalRep.doubleValue, dst); + (void) Tcl_InitStringRep(objPtr, NULL, strlen(dst)); } /* @@ -2673,14 +2669,9 @@ static void UpdateStringOfInt( register Tcl_Obj *objPtr) /* Int object whose string rep to update. */ { - char buffer[TCL_INTEGER_SPACE]; - register int len; - - len = TclFormatInt(buffer, objPtr->internalRep.longValue); - - objPtr->bytes = ckalloc(len + 1); - memcpy(objPtr->bytes, buffer, (unsigned) len + 1); - objPtr->length = len; + (void) Tcl_InitStringRep(objPtr, NULL, + TclFormatInt(Tcl_InitStringRep( objPtr, NULL, TCL_INTEGER_SPACE), + objPtr->internalRep.longValue)); } /* @@ -2784,6 +2775,7 @@ Tcl_DbNewLongObj( register Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); + /* Optimized TclInvalidateStringRep */ objPtr->bytes = NULL; objPtr->internalRep.longValue = longValue; @@ -2968,9 +2960,7 @@ static void UpdateStringOfWideInt( register Tcl_Obj *objPtr) /* Int object whose string rep to update. */ { - char buffer[TCL_INTEGER_SPACE+2]; - register unsigned len; - register Tcl_WideInt wideVal = objPtr->internalRep.wideValue; + char *dst = Tcl_InitStringRep(objPtr, NULL, TCL_INTEGER_SPACE + 2); /* * Note that sprintf will generate a compiler warning under Mingw claiming @@ -2979,11 +2969,9 @@ UpdateStringOfWideInt( * value. */ - sprintf(buffer, "%" TCL_LL_MODIFIER "d", wideVal); - len = strlen(buffer); - objPtr->bytes = ckalloc(len + 1); - memcpy(objPtr->bytes, buffer, len + 1); - objPtr->length = len; + sprintf(dst, "%" TCL_LL_MODIFIER "d", objPtr->internalRep.wideValue); + + (void) Tcl_InitStringRep(objPtr, NULL, strlen(dst)); } #endif /* !TCL_WIDE_INT_IS_LONG */ @@ -3353,12 +3341,10 @@ UpdateStringOfBignum( { mp_int bignumVal; int size; - int status; char *stringVal; UNPACK_BIGNUM(objPtr, bignumVal); - status = mp_radix_size(&bignumVal, 10, &size); - if (status != MP_OKAY) { + if (MP_OKAY != mp_radix_size(&bignumVal, 10, &size)) { Tcl_Panic("radix size failure in UpdateStringOfBignum"); } if (size == 3) { @@ -3375,13 +3361,12 @@ UpdateStringOfBignum( Tcl_Panic("UpdateStringOfBignum: string length limit exceeded"); } - stringVal = ckalloc(size); - status = mp_toradix_n(&bignumVal, stringVal, 10, size); - if (status != MP_OKAY) { + + stringVal = Tcl_InitStringRep(objPtr, NULL, size - 1); + if (MP_OKAY != mp_toradix_n(&bignumVal, stringVal, 10, size)) { Tcl_Panic("conversion failure in UpdateStringOfBignum"); } - objPtr->bytes = stringVal; - objPtr->length = size - 1; /* size includes a trailing NUL byte. */ + (void) Tcl_InitStringRep(objPtr, NULL, size - 1); } /* @@ -3501,9 +3486,15 @@ GetBignumFromObj( mp_init_copy(bignumValue, &temp); } else { UNPACK_BIGNUM(objPtr, *bignumValue); + /* Optimized TclFreeIntRep */ objPtr->internalRep.twoPtrValue.ptr1 = NULL; objPtr->internalRep.twoPtrValue.ptr2 = NULL; objPtr->typePtr = NULL; + /* + * TODO: If objPtr has a string rep, this leaves + * it undisturbed. Not clear that's proper. Pure + * bignum values are converted to empty string. + */ if (objPtr->bytes == NULL) { TclInitStringRep(objPtr, NULL, 0); } -- cgit v0.12 From 959413c95a407dc8c50631052a87aa02bc11ee2d Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 24 Mar 2016 15:01:43 +0000 Subject: More purging of direct access to bytes field where it isn't important. --- generic/tclCmdIL.c | 18 ++++-------------- 1 file changed, 4 insertions(+), 14 deletions(-) diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 739dca9..e32aff0 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -544,9 +544,9 @@ InfoBodyCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { register Interp *iPtr = (Interp *) interp; - const char *name; + const char *name, *bytes; Proc *procPtr; - Tcl_Obj *bodyPtr, *resultPtr; + int numBytes; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "procname"); @@ -571,18 +571,8 @@ InfoBodyCmd( * the object do not invalidate the internal rep. */ - bodyPtr = procPtr->bodyPtr; - if (bodyPtr->bytes == NULL) { - /* - * The string rep might not be valid if the procedure has never been - * run before. [Bug #545644] - */ - - TclGetString(bodyPtr); - } - resultPtr = Tcl_NewStringObj(bodyPtr->bytes, bodyPtr->length); - - Tcl_SetObjResult(interp, resultPtr); + bytes = Tcl_GetStringFromObj(procPtr->bodyPtr, &numBytes); + Tcl_SetObjResult(interp, Tcl_NewStringObj(bytes, numBytes)); return TCL_OK; } -- cgit v0.12 From 8370f3e2755cd93636a048bfd20d661ff7c56cbc Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 24 Mar 2016 19:21:47 +0000 Subject: Revise Tcl_InitStringRep() to do non-panic attempt at allocation. Let caller decide how catastrophic it is. Revise [string repeat] to use new routine. --- generic/tclCmdMZ.c | 21 +++++---------------- generic/tclObj.c | 7 +++++-- 2 files changed, 10 insertions(+), 18 deletions(-) diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 13f9e7d..02d050a 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -2275,11 +2275,9 @@ StringReptCmd( } length2 = length1 * count; - /* - * Include space for the NUL. - */ - - string2 = attemptckalloc((unsigned) length2 + 1); + TclNewObj(resultPtr); + Tcl_InvalidateStringRep(resultPtr); + string2 = Tcl_InitStringRep(resultPtr, NULL, length2); if (string2 == NULL) { /* * Alloc failed. Note that in this case we try to do an error message @@ -2292,22 +2290,13 @@ StringReptCmd( "string size overflow, out of memory allocating %u bytes", length2 + 1)); Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + Tcl_DecrRefCount(resultPtr); return TCL_ERROR; } for (index = 0; index < count; index++) { memcpy(string2 + (length1 * index), string1, (size_t) length1); } - string2[length2] = '\0'; - - /* - * We have to directly assign this instead of using Tcl_SetStringObj (and - * indirectly TclInitStringRep) because that makes another copy of the - * data. - */ - - TclNewObj(resultPtr); - resultPtr->bytes = string2; - resultPtr->length = length2; + (void) Tcl_InitStringRep(resultPtr, NULL, length2); Tcl_SetObjResult(interp, resultPtr); done: diff --git a/generic/tclObj.c b/generic/tclObj.c index aa81588..f1f4f1d 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -1758,7 +1758,10 @@ Tcl_InitStringRep( /* Allocate only as empty - extend later if bytes copied */ objPtr->length = 0; if (numBytes) { - objPtr->bytes = (char *)ckalloc(numBytes+1); + objPtr->bytes = attemptckalloc(numBytes + 1); + if (objPtr->bytes == NULL) { + return NULL; + } if (bytes) { /* Copy */ memcpy(objPtr->bytes, bytes, numBytes); @@ -1770,7 +1773,7 @@ Tcl_InitStringRep( } } else { /* objPtr->bytes != NULL bytes == NULL - Truncate */ - objPtr->bytes = (char *)ckrealloc(objPtr->bytes, numBytes+1); + objPtr->bytes = ckrealloc(objPtr->bytes, numBytes + 1); objPtr->length = (int)numBytes; } -- cgit v0.12 From 413706af15c4f39a0cec781c067faa9eefafd5b8 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 24 Mar 2016 20:15:01 +0000 Subject: Update Tcl_InitStringRep callers to handle OOM condition. --- generic/tclBinary.c | 4 +++- generic/tclDictObj.c | 3 +++ generic/tclEnsemble.c | 5 +++-- generic/tclInt.h | 7 +++++++ generic/tclObj.c | 12 ++++++++++-- generic/tclUtil.c | 2 ++ macosx/tclMacOSXFCmd.c | 7 +++++-- 7 files changed, 33 insertions(+), 7 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 7abb5c5..b7fea30 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -589,9 +589,11 @@ UpdateStringOfByteArray( } if (size == length) { - (void) Tcl_InitStringRep(objPtr, (char *)src, size); + char *dst = Tcl_InitStringRep(objPtr, (char *)src, size); + TclOOM(dst, size); } else { char *dst = Tcl_InitStringRep(objPtr, NULL, size); + TclOOM(dst, size); for (i = 0; i < length; i++) { dst += Tcl_UniCharToUtf(src[i], dst); } diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index 46fa623..ae7280a 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -560,6 +560,7 @@ UpdateStringOfDict( */ dst = Tcl_InitStringRep(dictPtr, NULL, bytesNeeded - 1); + TclOOM(dst, bytesNeeded) for (i=0,cPtr=dict->entryChainHead; inextPtr) { flagPtr[i] |= ( i ? TCL_DONT_QUOTE_HASH : 0 ); keyPtr = Tcl_GetHashKey(&dict->table, &cPtr->entry); @@ -677,6 +678,7 @@ SetDictFromAny( TclNewObj(keyPtr); Tcl_InvalidateStringRep(keyPtr); dst = Tcl_InitStringRep(keyPtr, NULL, elemSize); + TclOOM(dst, elemSize); /* Consider error */ (void)Tcl_InitStringRep(keyPtr, NULL, TclCopyAndCollapse(elemSize, elemStart, dst)); } @@ -696,6 +698,7 @@ SetDictFromAny( TclNewObj(valuePtr); Tcl_InvalidateStringRep(valuePtr); dst = Tcl_InitStringRep(valuePtr, NULL, elemSize); + TclOOM(dst, elemSize); /* Consider error */ (void)Tcl_InitStringRep(valuePtr, NULL, TclCopyAndCollapse(elemSize, elemStart, dst)); } diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 2ef2861..e034d6e 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -2703,9 +2703,10 @@ StringOfEnsembleCmdRep( Tcl_Obj *objPtr) { EnsembleCmdRep *ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1; + unsigned int size = strlen(ensembleCmd->fullSubcmdName); + char *dst = Tcl_InitStringRep(objPtr, ensembleCmd->fullSubcmdName, size); - Tcl_InitStringRep(objPtr, ensembleCmd->fullSubcmdName, - strlen(ensembleCmd->fullSubcmdName)); + TclOOM(dst, size); } /* diff --git a/generic/tclInt.h b/generic/tclInt.h index 462e1e0..50f7a76 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2314,6 +2314,13 @@ typedef struct Interp { #define TCL_ALIGN(x) (((int)(x) + 7) & ~7) /* + * A common panic alert when memory allocation fails. + */ + +#define TclOOM(ptr, size) \ + ((size) && ((ptr)||(Tcl_Panic("unable to alloc %u bytes", (size)),1))) + +/* * The following enum values are used to specify the runtime platform setting * of the tclPlatform variable. */ diff --git a/generic/tclObj.c b/generic/tclObj.c index f1f4f1d..2a35539 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -2481,6 +2481,8 @@ UpdateStringOfDouble( { char *dst = Tcl_InitStringRep(objPtr, NULL, TCL_DOUBLE_SPACE); + TclOOM(dst, TCL_DOUBLE_SPACE + 1); + Tcl_PrintDouble(NULL, objPtr->internalRep.doubleValue, dst); (void) Tcl_InitStringRep(objPtr, NULL, strlen(dst)); } @@ -2672,9 +2674,11 @@ static void UpdateStringOfInt( register Tcl_Obj *objPtr) /* Int object whose string rep to update. */ { + char *dst = Tcl_InitStringRep( objPtr, NULL, TCL_INTEGER_SPACE); + + TclOOM(dst, TCL_INTEGER_SPACE + 1); (void) Tcl_InitStringRep(objPtr, NULL, - TclFormatInt(Tcl_InitStringRep( objPtr, NULL, TCL_INTEGER_SPACE), - objPtr->internalRep.longValue)); + TclFormatInt(dst, objPtr->internalRep.longValue)); } /* @@ -2965,6 +2969,8 @@ UpdateStringOfWideInt( { char *dst = Tcl_InitStringRep(objPtr, NULL, TCL_INTEGER_SPACE + 2); + TclOOM(dst, TCL_INTEGER_SPACE + 3); + /* * Note that sprintf will generate a compiler warning under Mingw claiming * %I64 is an unknown format specifier. Just ignore this warning. We can't @@ -3366,6 +3372,8 @@ UpdateStringOfBignum( } stringVal = Tcl_InitStringRep(objPtr, NULL, size - 1); + + TclOOM(stringVal, size); if (MP_OKAY != mp_toradix_n(&bignumVal, stringVal, 10, size)) { Tcl_Panic("conversion failure in UpdateStringOfBignum"); } diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 1d5e8fe..01f8225 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -3656,6 +3656,8 @@ UpdateStringOfEndOffset( char *dst = Tcl_InitStringRep(objPtr, NULL, TCL_INTEGER_SPACE + 5); int len = 3; + TclOOM(dst, TCL_INTEGER_SPACE + 6); + memcpy(dst, "end", len); if (objPtr->internalRep.longValue != 0) { dst[len++] = '-'; diff --git a/macosx/tclMacOSXFCmd.c b/macosx/tclMacOSXFCmd.c index 13a939f..8659e95 100644 --- a/macosx/tclMacOSXFCmd.c +++ b/macosx/tclMacOSXFCmd.c @@ -695,9 +695,11 @@ UpdateStringOfOSType( const int size = TCL_UTF_MAX * 4; char *dst = Tcl_InitStringRep(objPtr, NULL, size); OSType osType = (OSType) objPtr->internalRep.longValue; - Tcl_Encoding encoding = Tcl_GetEncoding(NULL, "macRoman"); + int written = 0; + Tcl_Encoding encoding; char src[5]; - int written; + + TclOOM(dst, size); src[0] = (char) (osType >> 24); src[1] = (char) (osType >> 16); @@ -705,6 +707,7 @@ UpdateStringOfOSType( src[3] = (char) (osType); src[4] = '\0'; + encoding = Tcl_GetEncoding(NULL, "macRoman"); Tcl_ExternalToUtf(NULL, encoding, src, -1, /* flags */ 0, /* statePtr */ NULL, dst, size, /* srcReadPtr */ NULL, /* dstWrotePtr */ &written, /* dstCharsPtr */ NULL); -- cgit v0.12 From a19375e928a3f10c0d05c5cdbbfac0a838aee1db Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 24 Mar 2016 20:17:52 +0000 Subject: oops --- generic/tclDictObj.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index ae7280a..f7e825c 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -560,7 +560,7 @@ UpdateStringOfDict( */ dst = Tcl_InitStringRep(dictPtr, NULL, bytesNeeded - 1); - TclOOM(dst, bytesNeeded) + TclOOM(dst, bytesNeeded); for (i=0,cPtr=dict->entryChainHead; inextPtr) { flagPtr[i] |= ( i ? TCL_DONT_QUOTE_HASH : 0 ); keyPtr = Tcl_GetHashKey(&dict->table, &cPtr->entry); -- cgit v0.12 From 1bebb796bb6f2799a3f1bcc021481a6a71adcbc1 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 24 Mar 2016 20:33:27 +0000 Subject: Revise the "instname" Tcl_ObjType to use the routines. --- generic/tclDisassemble.c | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index c85fe13..ecd5f38 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -804,6 +804,7 @@ TclNewInstNameObj( objPtr->typePtr = &tclInstNameType; objPtr->internalRep.longValue = (long) inst; + /* Optimized Tcl_InvalidateStringRep */ objPtr->bytes = NULL; return objPtr; @@ -824,19 +825,19 @@ UpdateStringOfInstName( Tcl_Obj *objPtr) { int inst = objPtr->internalRep.longValue; - char *s, buf[20]; - int len; + char *dst; if ((inst < 0) || (inst > LAST_INST_OPCODE)) { - sprintf(buf, "inst_%d", inst); - s = buf; + dst = Tcl_InitStringRep(objPtr, NULL, TCL_INTEGER_SPACE + 4); + TclOOM(dst, TCL_INTEGER_SPACE + 4); + sprintf(dst, "inst_%d", inst); + (void) Tcl_InitStringRep(objPtr, NULL, strlen(dst)); } else { - s = (char *) tclInstructionTable[objPtr->internalRep.longValue].name; + const char *s = tclInstructionTable[objPtr->internalRep.longValue].name; + int len = strlen(s); + dst = Tcl_InitStringRep(objPtr, s, len); + TclOOM(dst, len); } - len = strlen(s); - objPtr->bytes = ckalloc(len + 1); - memcpy(objPtr->bytes, s, len + 1); - objPtr->length = len; } /* -- cgit v0.12 From a5e1e1f33e40417a5dbacb82a9f716a858aa12ec Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 24 Mar 2016 21:11:52 +0000 Subject: Revise the "index" Tcl_ObjType to use the new routine. --- generic/tclIndexObj.c | 8 +------- 1 file changed, 1 insertion(+), 7 deletions(-) diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index ce8b9fb..e00ca8c 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -449,15 +449,9 @@ UpdateStringOfIndex( Tcl_Obj *objPtr) { IndexRep *indexRep = objPtr->internalRep.twoPtrValue.ptr1; - register char *buf; - register unsigned len; register const char *indexStr = EXPAND_OF(indexRep); - len = strlen(indexStr); - buf = ckalloc(len + 1); - memcpy(buf, indexStr, len+1); - objPtr->bytes = buf; - objPtr->length = len; + Tcl_InitStringRep(objPtr, indexStr, strlen(indexStr)); } /* -- cgit v0.12 From c7039276a0e64e1cc8f2d8a813a9007eee1e89fa Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 25 Mar 2016 12:24:04 +0000 Subject: Create a type Tcl_ObjIntRep so we can pass intreps as arguments. --- generic/tcl.h | 44 ++++++++++++++++++++++++-------------------- 1 file changed, 24 insertions(+), 20 deletions(-) diff --git a/generic/tcl.h b/generic/tcl.h index 3cd90a9..c451579 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -801,6 +801,29 @@ typedef struct Tcl_ObjType { } Tcl_ObjType; /* + * The following structure stores an internal representation (intrep) for + * a Tcl value. An intrep is associated with an Tcl_ObjType when both + * are stored in the same Tcl_Obj. The routines of the Tcl_ObjType govern + * the handling of the intrep. + */ + +typedef union Tcl_ObjIntRep { /* The internal representation: */ + long longValue; /* - an long integer value. */ + double doubleValue; /* - a double-precision floating value. */ + void *otherValuePtr; /* - another, type-specific value, */ + /* not used internally any more. */ + Tcl_WideInt wideValue; /* - an integer value >= 64bits */ + struct { /* - internal rep as two pointers. */ + void *ptr1; + void *ptr2; + } twoPtrValue; + struct { /* - internal rep as a pointer and a long, */ + void *ptr; /* not used internally any more. */ + unsigned long value; + } ptrAndLongRep; +} Tcl_ObjIntRep; + +/* * One of the following structures exists for each object in the Tcl system. * An object stores a value as either a string, some internal representation, * or both. @@ -825,26 +848,7 @@ typedef struct Tcl_Obj { * corresponds to the type of the object's * internal rep. NULL indicates the object has * no internal rep (has no type). */ - union { /* The internal representation: */ - long longValue; /* - an long integer value. */ - double doubleValue; /* - a double-precision floating value. */ - void *otherValuePtr; /* - another, type-specific value, - not used internally any more. */ - Tcl_WideInt wideValue; /* - a long long value. */ - struct { /* - internal rep as two pointers. - * the main use of which is a bignum's - * tightly packed fields, where the alloc, - * used and signum flags are packed into - * ptr2 with everything else hung off ptr1. */ - void *ptr1; - void *ptr2; - } twoPtrValue; - struct { /* - internal rep as a pointer and a long, - not used internally any more. */ - void *ptr; - unsigned long value; - } ptrAndLongRep; - } internalRep; + Tcl_ObjIntRep internalRep; /* The internal representation: */ } Tcl_Obj; /* -- cgit v0.12 From f19cbcbff50d1926240759ab4e4bfcd0cc6e54d9 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 25 Mar 2016 13:06:53 +0000 Subject: New routines Tcl_FetchIntRep() and Tcl_StoreIntRep(). --- generic/tcl.decls | 8 ++++++ generic/tclDecls.h | 13 ++++++++++ generic/tclObj.c | 71 +++++++++++++++++++++++++++++++++++++++++++++++++++ generic/tclStubInit.c | 2 ++ 4 files changed, 94 insertions(+) diff --git a/generic/tcl.decls b/generic/tcl.decls index 2bb49b9..962a563 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2334,6 +2334,14 @@ declare 632 { char *Tcl_InitStringRep(Tcl_Obj *objPtr, const char *bytes, unsigned int numBytes) } +declare 633 { + const Tcl_ObjIntRep *Tcl_FetchIntRep(Tcl_Obj *objPtr, + const Tcl_ObjType *typePtr) +} +declare 634 { + void Tcl_StoreIntRep(Tcl_Obj *objPtr, const Tcl_ObjType *typePtr, + Tcl_ObjIntRep *irPtr) +} # ----- BASELINE -- FOR -- 8.7.0 ----- # diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 7114ad9..609ec86 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1821,6 +1821,13 @@ EXTERN void Tcl_FreeIntRep(Tcl_Obj *objPtr); /* 632 */ EXTERN char * Tcl_InitStringRep(Tcl_Obj *objPtr, const char *bytes, unsigned int numBytes); +/* 633 */ +EXTERN const Tcl_ObjIntRep * Tcl_FetchIntRep(Tcl_Obj *objPtr, + const Tcl_ObjType *typePtr); +/* 634 */ +EXTERN void Tcl_StoreIntRep(Tcl_Obj *objPtr, + const Tcl_ObjType *typePtr, + Tcl_ObjIntRep *irPtr); typedef struct { const struct TclPlatStubs *tclPlatStubs; @@ -2489,6 +2496,8 @@ typedef struct TclStubs { void (*tcl_ZlibStreamSetCompressionDictionary) (Tcl_ZlibStream zhandle, Tcl_Obj *compressionDictionaryObj); /* 630 */ void (*tcl_FreeIntRep) (Tcl_Obj *objPtr); /* 631 */ char * (*tcl_InitStringRep) (Tcl_Obj *objPtr, const char *bytes, unsigned int numBytes); /* 632 */ + const Tcl_ObjIntRep * (*tcl_FetchIntRep) (Tcl_Obj *objPtr, const Tcl_ObjType *typePtr); /* 633 */ + void (*tcl_StoreIntRep) (Tcl_Obj *objPtr, const Tcl_ObjType *typePtr, Tcl_ObjIntRep *irPtr); /* 634 */ } TclStubs; extern const TclStubs *tclStubsPtr; @@ -3785,6 +3794,10 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_FreeIntRep) /* 631 */ #define Tcl_InitStringRep \ (tclStubsPtr->tcl_InitStringRep) /* 632 */ +#define Tcl_FetchIntRep \ + (tclStubsPtr->tcl_FetchIntRep) /* 633 */ +#define Tcl_StoreIntRep \ + (tclStubsPtr->tcl_StoreIntRep) /* 634 */ #endif /* defined(USE_TCL_STUBS) */ diff --git a/generic/tclObj.c b/generic/tclObj.c index 2a35539..55426bf 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -1812,6 +1812,77 @@ Tcl_InvalidateStringRep( /* *---------------------------------------------------------------------- * + * Tcl_StoreIntRep -- + * + * This function is called to set the object's internal + * representation to match a particular type. + * + * It is the caller's responsibility to guarantee that + * the value of the submitted IntRep is in agreement with + * the value of any existing string rep. + * + * Results: + * None. + * + * Side effects: + * Calls the freeIntRepProc of the current Tcl_ObjType, if any. + * Sets the internalRep and typePtr fields to the submitted values. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_StoreIntRep( + Tcl_Obj *objPtr, /* Object whose internal rep should be set. */ + const Tcl_ObjType *typePtr, /* New type for the object */ + Tcl_ObjIntRep *irPtr) /* New IntRep for the object */ +{ + /* Clear out any existing IntRep ( "shimmer" ) */ + TclFreeIntRep(objPtr); + + /* Copy the new IntRep into place */ + objPtr->internalRep = *irPtr; + + /* Set the type to match */ + objPtr->typePtr = typePtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FetchIntRep -- + * + * This function is called to retrieve the object's internal + * representation matching a requested type, if any. + * + * Results: + * A read-only pointer to the associated Tcl_ObjIntRep, or + * NULL if no such internal representation exists. + * + * Side effects: + * Calls the freeIntRepProc of the current Tcl_ObjType, if any. + * Sets the internalRep and typePtr fields to the submitted values. + * + *---------------------------------------------------------------------- + */ + +const Tcl_ObjIntRep * +Tcl_FetchIntRep( + Tcl_Obj *objPtr, /* Object to fetch from. */ + const Tcl_ObjType *typePtr) /* Requested type */ +{ + /* If objPtr type doesn't match request, nothing can be fetched */ + if (objPtr->typePtr != typePtr) { + return NULL; + } + + /* Type match! objPtr IntRep is the one sought. */ + return &(objPtr->internalRep); +} + +/* + *---------------------------------------------------------------------- + * * Tcl_FreeIntRep -- * * This function is called to free an object's internal representation. diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 775d4ac..2af47b7 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -1417,6 +1417,8 @@ const TclStubs tclStubs = { Tcl_ZlibStreamSetCompressionDictionary, /* 630 */ Tcl_FreeIntRep, /* 631 */ Tcl_InitStringRep, /* 632 */ + Tcl_FetchIntRep, /* 633 */ + Tcl_StoreIntRep, /* 634 */ }; /* !END!: Do not edit above this line. */ -- cgit v0.12 From 36cf99464d3e6a33deda928dbb3d0b1abe4cf82f Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 25 Mar 2016 14:01:00 +0000 Subject: First demonstration conversion to the new intrep manipulation routines. --- generic/tcl.decls | 2 +- generic/tclDecls.h | 4 ++-- generic/tclIndexObj.c | 61 ++++++++++++++++++++++++++++----------------------- 3 files changed, 37 insertions(+), 30 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index 962a563..15b7040 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2340,7 +2340,7 @@ declare 633 { } declare 634 { void Tcl_StoreIntRep(Tcl_Obj *objPtr, const Tcl_ObjType *typePtr, - Tcl_ObjIntRep *irPtr) + const Tcl_ObjIntRep *irPtr) } # ----- BASELINE -- FOR -- 8.7.0 ----- # diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 609ec86..5ea9151 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1827,7 +1827,7 @@ EXTERN const Tcl_ObjIntRep * Tcl_FetchIntRep(Tcl_Obj *objPtr, /* 634 */ EXTERN void Tcl_StoreIntRep(Tcl_Obj *objPtr, const Tcl_ObjType *typePtr, - Tcl_ObjIntRep *irPtr); + const Tcl_ObjIntRep *irPtr); typedef struct { const struct TclPlatStubs *tclPlatStubs; @@ -2497,7 +2497,7 @@ typedef struct TclStubs { void (*tcl_FreeIntRep) (Tcl_Obj *objPtr); /* 631 */ char * (*tcl_InitStringRep) (Tcl_Obj *objPtr, const char *bytes, unsigned int numBytes); /* 632 */ const Tcl_ObjIntRep * (*tcl_FetchIntRep) (Tcl_Obj *objPtr, const Tcl_ObjType *typePtr); /* 633 */ - void (*tcl_StoreIntRep) (Tcl_Obj *objPtr, const Tcl_ObjType *typePtr, Tcl_ObjIntRep *irPtr); /* 634 */ + void (*tcl_StoreIntRep) (Tcl_Obj *objPtr, const Tcl_ObjType *typePtr, const Tcl_ObjIntRep *irPtr); /* 634 */ } TclStubs; extern const TclStubs *tclStubsPtr; diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index e00ca8c..836f60b 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -114,15 +114,16 @@ Tcl_GetIndexFromObj( int flags, /* 0 or TCL_EXACT */ int *indexPtr) /* Place to store resulting integer index. */ { - /* * See if there is a valid cached result from a previous lookup (doing the * check here saves the overhead of calling Tcl_GetIndexFromObjStruct in * the common case where the result is cached). */ - if (objPtr->typePtr == &indexType) { - IndexRep *indexRep = objPtr->internalRep.twoPtrValue.ptr1; + const Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(objPtr, &indexType); + + if (irPtr) { + IndexRep *indexRep = irPtr->twoPtrValue.ptr1; /* * Here's hoping we don't get hit by unfortunate packing constraints @@ -270,6 +271,7 @@ Tcl_GetIndexFromObjStruct( const char *const *entryPtr; Tcl_Obj *resultPtr; IndexRep *indexRep; + const Tcl_ObjIntRep *irPtr; /* Protect against invalid values, like -1 or 0. */ if (offset < (int)sizeof(char *)) { @@ -279,8 +281,9 @@ Tcl_GetIndexFromObjStruct( * See if there is a valid cached result from a previous lookup. */ - if (objPtr->typePtr == &indexType) { - indexRep = objPtr->internalRep.twoPtrValue.ptr1; + irPtr = Tcl_FetchIntRep(objPtr, &indexType); + if (irPtr) { + indexRep = irPtr->twoPtrValue.ptr1; if (indexRep->tablePtr==tablePtr && indexRep->offset==offset) { *indexPtr = indexRep->index; return TCL_OK; @@ -340,13 +343,15 @@ Tcl_GetIndexFromObjStruct( * operation. */ - if (objPtr->typePtr == &indexType) { - indexRep = objPtr->internalRep.twoPtrValue.ptr1; + irPtr = Tcl_FetchIntRep(objPtr, &indexType); + if (irPtr) { + indexRep = irPtr->twoPtrValue.ptr1; } else { - TclFreeIntRep(objPtr); + Tcl_ObjIntRep ir; + indexRep = ckalloc(sizeof(IndexRep)); - objPtr->internalRep.twoPtrValue.ptr1 = indexRep; - objPtr->typePtr = &indexType; + ir.twoPtrValue.ptr1 = indexRep; + Tcl_StoreIntRep(objPtr, &indexType, &ir); } indexRep->tablePtr = (void *) tablePtr; indexRep->offset = offset; @@ -448,7 +453,7 @@ static void UpdateStringOfIndex( Tcl_Obj *objPtr) { - IndexRep *indexRep = objPtr->internalRep.twoPtrValue.ptr1; + IndexRep *indexRep = Tcl_FetchIntRep(objPtr, &indexType)->twoPtrValue.ptr1; register const char *indexStr = EXPAND_OF(indexRep); Tcl_InitStringRep(objPtr, indexStr, strlen(indexStr)); @@ -477,12 +482,14 @@ DupIndex( Tcl_Obj *srcPtr, Tcl_Obj *dupPtr) { - IndexRep *srcIndexRep = srcPtr->internalRep.twoPtrValue.ptr1; + Tcl_ObjIntRep ir; IndexRep *dupIndexRep = ckalloc(sizeof(IndexRep)); - memcpy(dupIndexRep, srcIndexRep, sizeof(IndexRep)); - dupPtr->internalRep.twoPtrValue.ptr1 = dupIndexRep; - dupPtr->typePtr = &indexType; + memcpy(dupIndexRep, Tcl_FetchIntRep(srcPtr, &indexType)->twoPtrValue.ptr1, + sizeof(IndexRep)); + + ir.twoPtrValue.ptr1 = dupIndexRep; + Tcl_StoreIntRep(dupPtr, &indexType, &ir); } /* @@ -506,7 +513,7 @@ static void FreeIndex( Tcl_Obj *objPtr) { - ckfree(objPtr->internalRep.twoPtrValue.ptr1); + ckfree(Tcl_FetchIntRep(objPtr, &indexType)->twoPtrValue.ptr1); objPtr->typePtr = NULL; } @@ -944,16 +951,16 @@ Tcl_WrongNumArgs( /* * Add the element, quoting it if necessary. */ + const Tcl_ObjIntRep *irPtr; - if (origObjv[i]->typePtr == &indexType) { - register IndexRep *indexRep = - origObjv[i]->internalRep.twoPtrValue.ptr1; + if ((irPtr = Tcl_FetchIntRep(origObjv[i], &indexType))) { + register IndexRep *indexRep = irPtr->twoPtrValue.ptr1; elementStr = EXPAND_OF(indexRep); elemLen = strlen(elementStr); - } else if (origObjv[i]->typePtr == &tclEnsembleCmdType) { - register EnsembleCmdRep *ecrPtr = - origObjv[i]->internalRep.twoPtrValue.ptr1; + } else if ((irPtr = + Tcl_FetchIntRep(origObjv[i], &tclEnsembleCmdType))) { + register EnsembleCmdRep *ecrPtr = irPtr->twoPtrValue.ptr1; elementStr = ecrPtr->fullSubcmdName; elemLen = strlen(elementStr); @@ -1000,14 +1007,14 @@ Tcl_WrongNumArgs( * the correct error message even if the subcommand was abbreviated. * Otherwise, just use the string rep. */ + const Tcl_ObjIntRep *irPtr; - if (objv[i]->typePtr == &indexType) { - register IndexRep *indexRep = objv[i]->internalRep.twoPtrValue.ptr1; + if ((irPtr = Tcl_FetchIntRep(objv[i], &indexType))) { + register IndexRep *indexRep = irPtr->twoPtrValue.ptr1; Tcl_AppendStringsToObj(objPtr, EXPAND_OF(indexRep), NULL); - } else if (objv[i]->typePtr == &tclEnsembleCmdType) { - register EnsembleCmdRep *ecrPtr = - objv[i]->internalRep.twoPtrValue.ptr1; + } else if ((irPtr = Tcl_FetchIntRep(objv[i], &tclEnsembleCmdType))) { + register EnsembleCmdRep *ecrPtr = irPtr->twoPtrValue.ptr1; Tcl_AppendStringsToObj(objPtr, ecrPtr->fullSubcmdName, NULL); } else { -- cgit v0.12 From 3bd88409318cdd99b39ad5ce49b87f880f01cf37 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 25 Mar 2016 19:56:56 +0000 Subject: Get signatures in sync. --- generic/tclObj.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclObj.c b/generic/tclObj.c index 55426bf..3341fcd 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -1835,7 +1835,7 @@ void Tcl_StoreIntRep( Tcl_Obj *objPtr, /* Object whose internal rep should be set. */ const Tcl_ObjType *typePtr, /* New type for the object */ - Tcl_ObjIntRep *irPtr) /* New IntRep for the object */ + const Tcl_ObjIntRep *irPtr) /* New IntRep for the object */ { /* Clear out any existing IntRep ( "shimmer" ) */ TclFreeIntRep(objPtr); -- cgit v0.12 From 0276b6e64460992b893edd94845a3daaa7773c2d Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 25 Mar 2016 20:01:39 +0000 Subject: irPtr = NULL passed to Tcl_StoreIntRep clears out any value for typePtr. --- generic/tclObj.c | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/generic/tclObj.c b/generic/tclObj.c index 3341fcd..7db9ff9 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -1840,11 +1840,14 @@ Tcl_StoreIntRep( /* Clear out any existing IntRep ( "shimmer" ) */ TclFreeIntRep(objPtr); - /* Copy the new IntRep into place */ - objPtr->internalRep = *irPtr; + /* When irPtr == NULL, just leave objPtr with no IntRep for typePtr */ + if (irPtr) { + /* Copy the new IntRep into place */ + objPtr->internalRep = *irPtr; - /* Set the type to match */ - objPtr->typePtr = typePtr; + /* Set the type to match */ + objPtr->typePtr = typePtr; + } } /* -- cgit v0.12 From 6fd2ed3f11fb3b019f5d859bfe55b8aa1e7709be Mon Sep 17 00:00:00 2001 From: dgp Date: Sat, 26 Mar 2016 12:36:01 +0000 Subject: Convert the "bytearray" Tcl_ObjType to use the proposed Tcl_ObjIntRep manipulation routines. This works, but requires too much ugliness. The ugliness reveals that the interface needs some refinement, making this a rejected branch of development. --- generic/tclBinary.c | 109 ++++++++++++++++++++++++++++++---------------------- 1 file changed, 63 insertions(+), 46 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index b7fea30..8e791d5 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -207,10 +207,9 @@ typedef struct ByteArray { #define BYTEARRAY_SIZE(len) \ ((unsigned) (TclOffset(ByteArray, bytes) + (len))) -#define GET_BYTEARRAY(objPtr) \ - ((ByteArray *) (objPtr)->internalRep.twoPtrValue.ptr1) -#define SET_BYTEARRAY(objPtr, baPtr) \ - (objPtr)->internalRep.twoPtrValue.ptr1 = (void *) (baPtr) +#define GET_BYTEARRAY(irPtr) ((ByteArray *) (irPtr)->twoPtrValue.ptr1) +#define SET_BYTEARRAY(irPtr, baPtr) \ + (irPtr)->twoPtrValue.ptr1 = (void *) (baPtr) /* @@ -325,11 +324,11 @@ Tcl_SetByteArrayObj( be >= 0. */ { ByteArray *byteArrayPtr; + Tcl_ObjIntRep ir; if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_SetByteArrayObj"); } - TclFreeIntRep(objPtr); TclInvalidateStringRep(objPtr); if (length < 0) { @@ -342,8 +341,9 @@ Tcl_SetByteArrayObj( if ((bytes != NULL) && (length > 0)) { memcpy(byteArrayPtr->bytes, bytes, (size_t) length); } - objPtr->typePtr = &tclByteArrayType; - SET_BYTEARRAY(objPtr, byteArrayPtr); + SET_BYTEARRAY(&ir, byteArrayPtr); + + Tcl_StoreIntRep(objPtr, &tclByteArrayType, &ir); } /* @@ -371,16 +371,18 @@ Tcl_GetByteArrayFromObj( * array of bytes in the ByteArray object. */ { ByteArray *baPtr; + const Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(objPtr, &tclByteArrayType); - if (objPtr->typePtr != &tclByteArrayType) { + if (irPtr == NULL) { SetByteArrayFromAny(NULL, objPtr); + irPtr = Tcl_FetchIntRep(objPtr, &tclByteArrayType); } - baPtr = GET_BYTEARRAY(objPtr); + baPtr = GET_BYTEARRAY(irPtr); if (lengthPtr != NULL) { *lengthPtr = baPtr->used; } - return (unsigned char *) baPtr->bytes; + return baPtr->bytes; } /* @@ -412,6 +414,7 @@ Tcl_SetByteArrayLength( { ByteArray *byteArrayPtr; unsigned newLength; + const Tcl_ObjIntRep *irPtr; assert(length >= 0); newLength = (unsigned int)length; @@ -419,15 +422,22 @@ Tcl_SetByteArrayLength( if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_SetByteArrayLength"); } - if (objPtr->typePtr != &tclByteArrayType) { + irPtr = Tcl_FetchIntRep(objPtr, &tclByteArrayType); + if (irPtr == NULL) { SetByteArrayFromAny(NULL, objPtr); + irPtr = Tcl_FetchIntRep(objPtr, &tclByteArrayType); } - byteArrayPtr = GET_BYTEARRAY(objPtr); + byteArrayPtr = GET_BYTEARRAY(irPtr); if (newLength > byteArrayPtr->allocated) { + Tcl_ObjIntRep ir; + +/* UGLY UGLY UGLY */ +objPtr->typePtr = NULL; byteArrayPtr = ckrealloc(byteArrayPtr, BYTEARRAY_SIZE(newLength)); byteArrayPtr->allocated = newLength; - SET_BYTEARRAY(objPtr, byteArrayPtr); + SET_BYTEARRAY(&ir, byteArrayPtr); + Tcl_StoreIntRep(objPtr, &tclByteArrayType, &ir); } TclInvalidateStringRep(objPtr); byteArrayPtr->used = newLength; @@ -459,25 +469,26 @@ SetByteArrayFromAny( const char *src, *srcEnd; unsigned char *dst; ByteArray *byteArrayPtr; - Tcl_UniChar ch; + Tcl_ObjIntRep ir; - if (objPtr->typePtr != &tclByteArrayType) { - src = TclGetStringFromObj(objPtr, &length); - srcEnd = src + length; + assert (NULL == Tcl_FetchIntRep(objPtr, &tclByteArrayType)); - byteArrayPtr = ckalloc(BYTEARRAY_SIZE(length)); - for (dst = byteArrayPtr->bytes; src < srcEnd; ) { - src += Tcl_UtfToUniChar(src, &ch); - *dst++ = UCHAR(ch); - } + src = TclGetStringFromObj(objPtr, &length); + srcEnd = src + length; - byteArrayPtr->used = dst - byteArrayPtr->bytes; - byteArrayPtr->allocated = length; + byteArrayPtr = ckalloc(BYTEARRAY_SIZE(length)); + for (dst = byteArrayPtr->bytes; src < srcEnd; ) { + Tcl_UniChar ch; - TclFreeIntRep(objPtr); - objPtr->typePtr = &tclByteArrayType; - SET_BYTEARRAY(objPtr, byteArrayPtr); + src += Tcl_UtfToUniChar(src, &ch); + *dst++ = UCHAR(ch); } + + byteArrayPtr->used = dst - byteArrayPtr->bytes; + byteArrayPtr->allocated = length; + + SET_BYTEARRAY(&ir, byteArrayPtr); + Tcl_StoreIntRep(objPtr, &tclByteArrayType, &ir); return TCL_OK; } @@ -502,8 +513,7 @@ static void FreeByteArrayInternalRep( Tcl_Obj *objPtr) /* Object with internal rep to free. */ { - ckfree(GET_BYTEARRAY(objPtr)); - objPtr->typePtr = NULL; + ckfree(GET_BYTEARRAY(Tcl_FetchIntRep(objPtr, &tclByteArrayType))); } /* @@ -530,17 +540,18 @@ DupByteArrayInternalRep( { unsigned int length; ByteArray *srcArrayPtr, *copyArrayPtr; + Tcl_ObjIntRep ir; - srcArrayPtr = GET_BYTEARRAY(srcPtr); + srcArrayPtr = GET_BYTEARRAY(Tcl_FetchIntRep(srcPtr, &tclByteArrayType)); length = srcArrayPtr->used; copyArrayPtr = ckalloc(BYTEARRAY_SIZE(length)); copyArrayPtr->used = length; copyArrayPtr->allocated = length; memcpy(copyArrayPtr->bytes, srcArrayPtr->bytes, (size_t) length); - SET_BYTEARRAY(copyPtr, copyArrayPtr); - copyPtr->typePtr = &tclByteArrayType; + SET_BYTEARRAY(&ir, copyArrayPtr); + Tcl_StoreIntRep(copyPtr, &tclByteArrayType, &ir); } /* @@ -548,9 +559,7 @@ DupByteArrayInternalRep( * * UpdateStringOfByteArray -- * - * Update the string representation for a ByteArray data object. Note: - * This procedure does not invalidate an existing old string rep so - * storage will be lost if this has not already been done. + * Update the string representation for a ByteArray data object. * * Results: * None. @@ -559,9 +568,6 @@ DupByteArrayInternalRep( * The object's string is set to a valid string that results from the * ByteArray-to-string conversion. * - * The object becomes a string object -- the internal rep is discarded - * and the typePtr becomes NULL. - * *---------------------------------------------------------------------- */ @@ -570,7 +576,8 @@ UpdateStringOfByteArray( Tcl_Obj *objPtr) /* ByteArray object whose string rep to * update. */ { - ByteArray *byteArrayPtr = GET_BYTEARRAY(objPtr); + const Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(objPtr, &tclByteArrayType); + ByteArray *byteArrayPtr = GET_BYTEARRAY(irPtr); unsigned char *src = byteArrayPtr->bytes; unsigned int i, length = byteArrayPtr->used; unsigned int size = length; @@ -628,6 +635,7 @@ TclAppendBytesToByteArray( { ByteArray *byteArrayPtr; unsigned int length, needed; + const Tcl_ObjIntRep *irPtr; if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object","TclAppendBytesToByteArray"); @@ -641,10 +649,13 @@ TclAppendBytesToByteArray( return; } length = (unsigned int)len; - if (objPtr->typePtr != &tclByteArrayType) { + + irPtr = Tcl_FetchIntRep(objPtr, &tclByteArrayType); + if (irPtr == NULL) { SetByteArrayFromAny(NULL, objPtr); + irPtr = Tcl_FetchIntRep(objPtr, &tclByteArrayType); } - byteArrayPtr = GET_BYTEARRAY(objPtr); + byteArrayPtr = GET_BYTEARRAY(irPtr); if (length > INT_MAX - byteArrayPtr->used) { Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); @@ -658,7 +669,10 @@ TclAppendBytesToByteArray( if (needed > byteArrayPtr->allocated) { ByteArray *ptr = NULL; unsigned int attempt; + Tcl_ObjIntRep ir; +/* UGLY UGLY UGLY */ +objPtr->typePtr = NULL; if (needed <= INT_MAX/2) { /* Try to allocate double the total space that is needed. */ attempt = 2 * needed; @@ -680,7 +694,8 @@ TclAppendBytesToByteArray( } byteArrayPtr = ptr; byteArrayPtr->allocated = attempt; - SET_BYTEARRAY(objPtr, byteArrayPtr); + SET_BYTEARRAY(&ir, byteArrayPtr); + Tcl_StoreIntRep(objPtr, &tclByteArrayType, &ir); } if (bytes) { @@ -1880,10 +1895,11 @@ FormatNumber( */ if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) { - if (src->typePtr != &tclDoubleType) { + const Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(src, &tclDoubleType); + if (irPtr == NULL) { return TCL_ERROR; } - dvalue = src->internalRep.doubleValue; + dvalue = irPtr->doubleValue; } CopyNumber(&dvalue, *cursorPtr, sizeof(double), type); *cursorPtr += sizeof(double); @@ -1899,10 +1915,11 @@ FormatNumber( */ if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) { - if (src->typePtr != &tclDoubleType) { + const Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(src, &tclDoubleType); + if (irPtr == NULL) { return TCL_ERROR; } - dvalue = src->internalRep.doubleValue; + dvalue = irPtr->doubleValue; } /* -- cgit v0.12 From dcb52d2ea8467df98c8dc6f28c95a57347080acc Mon Sep 17 00:00:00 2001 From: dgp Date: Sun, 27 Mar 2016 17:07:50 +0000 Subject: A few more easy conversions. --- generic/tclClock.c | 2 +- generic/tclCmdMZ.c | 24 ++++++++++++------------ 2 files changed, 13 insertions(+), 13 deletions(-) diff --git a/generic/tclClock.c b/generic/tclClock.c index 949cb1c..a458cb9 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -438,7 +438,7 @@ ClockGetdatefieldsObjCmd( * that it isn't. */ - if (objv[1]->typePtr == &tclBignumType) { + if (Tcl_FetchIntRep(objv[1], &tclBignumType)) { Tcl_SetObjResult(interp, literals[LIT_INTEGER_VALUE_TOO_LARGE]); return TCL_ERROR; } diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 02d050a..71e8555 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -1567,12 +1567,12 @@ StringIsCmd( break; case STR_IS_DOUBLE: { /* TODO */ - if ((objPtr->typePtr == &tclDoubleType) || - (objPtr->typePtr == &tclIntType) || + if (Tcl_FetchIntRep(objPtr, &tclDoubleType) || + Tcl_FetchIntRep(objPtr, &tclIntType) || #ifndef TCL_WIDE_INT_IS_LONG - (objPtr->typePtr == &tclWideIntType) || + Tcl_FetchIntRep(objPtr, &tclWideIntType) || #endif - (objPtr->typePtr == &tclBignumType)) { + Tcl_FetchIntRep(objPtr, &tclBignumType)) { break; } string1 = TclGetStringFromObj(objPtr, &length1); @@ -1605,11 +1605,11 @@ StringIsCmd( } goto failedIntParse; case STR_IS_ENTIER: - if ((objPtr->typePtr == &tclIntType) || + if (Tcl_FetchIntRep(objPtr, &tclIntType) || #ifndef TCL_WIDE_INT_IS_LONG - (objPtr->typePtr == &tclWideIntType) || + Tcl_FetchIntRep(objPtr, &tclWideIntType) || #endif - (objPtr->typePtr == &tclBignumType)) { + Tcl_FetchIntRep(objPtr, &tclBignumType)) { break; } string1 = TclGetStringFromObj(objPtr, &length1); @@ -1880,7 +1880,7 @@ StringMapCmd( * inconsistencies (see test string-10.20 for illustration why!) */ - if (objv[objc-2]->typePtr == &tclDictType && objv[objc-2]->bytes == NULL){ + if (Tcl_FetchIntRep(objv[objc-2], &tclDictType) && objv[objc-2]->bytes == NULL){ int i, done; Tcl_DictSearch search; @@ -2621,8 +2621,8 @@ StringEqualCmd( string1 = (char *) Tcl_GetByteArrayFromObj(objv[0], &length1); string2 = (char *) Tcl_GetByteArrayFromObj(objv[1], &length2); strCmpFn = (strCmpFn_t) memcmp; - } else if ((objv[0]->typePtr == &tclStringType) - && (objv[1]->typePtr == &tclStringType)) { + } else if (Tcl_FetchIntRep(objv[0], &tclStringType) + && Tcl_FetchIntRep(objv[1], &tclStringType)) { /* * Do a unicode-specific comparison if both of the args are of String * type. In benchmark testing this proved the most efficient check @@ -2771,8 +2771,8 @@ StringCmpCmd( string1 = (char *) Tcl_GetByteArrayFromObj(objv[0], &length1); string2 = (char *) Tcl_GetByteArrayFromObj(objv[1], &length2); strCmpFn = (strCmpFn_t) memcmp; - } else if ((objv[0]->typePtr == &tclStringType) - && (objv[1]->typePtr == &tclStringType)) { + } else if (Tcl_FetchIntRep(objv[0], &tclStringType) + && Tcl_FetchIntRep(objv[1], &tclStringType)) { /* * Do a unicode-specific comparison if both of the args are of String * type. In benchmark testing this proved the most efficient check -- cgit v0.12 From 30d0cf44cb0f60e3aeeff3483eaac7b80bab79aa Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 29 Mar 2016 20:07:42 +0000 Subject: Functional conversion of "list" Tcl_ObjType to proposed routines. Not yet completely tidy and finished. --- generic/tclDictObj.c | 2 +- generic/tclExecute.c | 2 +- generic/tclInt.h | 14 +--- generic/tclListObj.c | 207 ++++++++++++++++++++++++++++++++------------------- 4 files changed, 137 insertions(+), 88 deletions(-) diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index f7e825c..6e54137 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -618,7 +618,7 @@ SetDictFromAny( * the conversion from lists to dictionaries. */ - if (objPtr->typePtr == &tclListType) { + if (Tcl_FetchIntRep(objPtr, &tclListType)) { int objc, i; Tcl_Obj **objv; diff --git a/generic/tclExecute.c b/generic/tclExecute.c index d4077f5..b3a8d8e 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5043,7 +5043,7 @@ TEBCresume( */ if ((TclListObjGetElements(interp, valuePtr, &objc, &objv) == TCL_OK) - && (value2Ptr->typePtr != &tclListType) + && (NULL == Tcl_FetchIntRep(value2Ptr, &tclListType)) && (TclGetIntForIndexM(NULL , value2Ptr, objc-1, &index) == TCL_OK)) { TclDecrRefCount(value2Ptr); diff --git a/generic/tclInt.h b/generic/tclInt.h index 50f7a76..2de0046 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2394,12 +2394,6 @@ typedef struct List { #define ListRepPtr(listPtr) \ ((List *) (listPtr)->internalRep.twoPtrValue.ptr1) -#define ListSetIntRep(objPtr, listRepPtr) \ - (objPtr)->internalRep.twoPtrValue.ptr1 = (void *)(listRepPtr), \ - (objPtr)->internalRep.twoPtrValue.ptr2 = NULL, \ - (listRepPtr)->refCount++, \ - (objPtr)->typePtr = &tclListType - #define ListObjGetElements(listPtr, objc, objv) \ ((objv) = &(ListRepPtr(listPtr)->elements), \ (objc) = ListRepPtr(listPtr)->elemCount) @@ -4266,11 +4260,11 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, */ #define TclInvalidateStringRep(objPtr) \ - if (objPtr->bytes != NULL) { \ - if (objPtr->bytes != tclEmptyStringRep) { \ - ckfree((char *) objPtr->bytes); \ + if ((objPtr)->bytes != NULL) { \ + if ((objPtr)->bytes != tclEmptyStringRep) { \ + ckfree((char *) (objPtr)->bytes); \ } \ - objPtr->bytes = NULL; \ + (objPtr)->bytes = NULL; \ } /* diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 14b8a14..0b6473b 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -12,6 +12,7 @@ */ #include "tclInt.h" +#include /* * Prototypes for functions defined later in this file: @@ -46,6 +47,27 @@ const Tcl_ObjType tclListType = { SetListFromAny /* setFromAnyProc */ }; +/* Macros to manipulate the List internal rep */ + +#define ListSetIntRep(objPtr, listRepPtr) \ + do { \ + Tcl_ObjIntRep ir; \ + ir.twoPtrValue.ptr1 = (listRepPtr); \ + ir.twoPtrValue.ptr2 = NULL; \ + (listRepPtr)->refCount++; \ + Tcl_StoreIntRep((objPtr), &tclListType, &ir); \ + } while (0) + +#define ListGetIntRep(objPtr, listRepPtr) \ + do { \ + const Tcl_ObjIntRep *irPtr; \ + irPtr = Tcl_FetchIntRep((objPtr), &tclListType); \ + (listRepPtr) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \ + } while (0) + +#define ListResetIntRep(objPtr, listRepPtr) \ + Tcl_FetchIntRep((objPtr), &tclListType)->twoPtrValue.ptr1 = (listRepPtr) + #ifndef TCL_MIN_ELEMENT_GROWTH #define TCL_MIN_ELEMENT_GROWTH TCL_MIN_GROWTH/sizeof(Tcl_Obj *) #endif @@ -374,8 +396,7 @@ Tcl_SetListObj( listRepPtr = NewListIntRep(objc, objv, 1); ListSetIntRep(objPtr, listRepPtr); } else { - objPtr->bytes = tclEmptyStringRep; - objPtr->length = 0; + Tcl_InitStringRep(objPtr, NULL, 0); } } @@ -407,8 +428,10 @@ TclListObjCopy( * to be returned. */ { Tcl_Obj *copyPtr; + List *listRepPtr; - if (listPtr->typePtr != &tclListType) { + ListGetIntRep(listPtr, listRepPtr); + if (NULL == listRepPtr) { if (SetListFromAny(interp, listPtr) != TCL_OK) { return NULL; } @@ -462,10 +485,13 @@ Tcl_ListObjGetElements( { register List *listRepPtr; - if (listPtr->typePtr != &tclListType) { - int result; + ListGetIntRep(listPtr, listRepPtr); - if (listPtr->bytes == tclEmptyStringRep) { + if (listRepPtr == NULL) { + int result, length; + + (void) Tcl_GetStringFromObj(listPtr, &length); + if (length == 0) { *objcPtr = 0; *objvPtr = NULL; return TCL_OK; @@ -474,8 +500,8 @@ Tcl_ListObjGetElements( if (result != TCL_OK) { return result; } + ListGetIntRep(listPtr, listRepPtr); } - listRepPtr = ListRepPtr(listPtr); *objcPtr = listRepPtr->elemCount; *objvPtr = &listRepPtr->elements; return TCL_OK; @@ -572,10 +598,13 @@ Tcl_ListObjAppendElement( if (Tcl_IsShared(listPtr)) { Tcl_Panic("%s called with shared object", "Tcl_ListObjAppendElement"); } - if (listPtr->typePtr != &tclListType) { - int result; - if (listPtr->bytes == tclEmptyStringRep) { + ListGetIntRep(listPtr, listRepPtr); + if (listRepPtr == NULL) { + int result, length; + + (void) Tcl_GetStringFromObj(listPtr, &length); + if (length == 0) { Tcl_SetListObj(listPtr, 1, &objPtr); return TCL_OK; } @@ -583,9 +612,9 @@ Tcl_ListObjAppendElement( if (result != TCL_OK) { return result; } + ListGetIntRep(listPtr, listRepPtr); } - listRepPtr = ListRepPtr(listPtr); numElems = listRepPtr->elemCount; numRequired = numElems + 1 ; needGrow = (numRequired > listRepPtr->maxElemCount); @@ -681,7 +710,7 @@ Tcl_ListObjAppendElement( } listRepPtr = newPtr; } - listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr; + ListResetIntRep(listPtr, listRepPtr); /* * Add objPtr to the end of listPtr's array of element pointers. Increment @@ -736,10 +765,12 @@ Tcl_ListObjIndex( { register List *listRepPtr; - if (listPtr->typePtr != &tclListType) { - int result; + ListGetIntRep(listPtr, listRepPtr); + if (listRepPtr == NULL) { + int result, length; - if (listPtr->bytes == tclEmptyStringRep) { + (void) Tcl_GetStringFromObj(listPtr, &length); + if (length == 0) { *objPtrPtr = NULL; return TCL_OK; } @@ -747,9 +778,9 @@ Tcl_ListObjIndex( if (result != TCL_OK) { return result; } + ListGetIntRep(listPtr, listRepPtr); } - listRepPtr = ListRepPtr(listPtr); if ((index < 0) || (index >= listRepPtr->elemCount)) { *objPtrPtr = NULL; } else { @@ -789,10 +820,12 @@ Tcl_ListObjLength( { register List *listRepPtr; - if (listPtr->typePtr != &tclListType) { - int result; + ListGetIntRep(listPtr, listRepPtr); + if (listRepPtr == NULL) { + int result, length; - if (listPtr->bytes == tclEmptyStringRep) { + (void) Tcl_GetStringFromObj(listPtr, &length); + if (length == 0) { *intPtr = 0; return TCL_OK; } @@ -800,9 +833,9 @@ Tcl_ListObjLength( if (result != TCL_OK) { return result; } + ListGetIntRep(listPtr, listRepPtr); } - listRepPtr = ListRepPtr(listPtr); *intPtr = listRepPtr->elemCount; return TCL_OK; } @@ -862,9 +895,14 @@ Tcl_ListObjReplace( if (Tcl_IsShared(listPtr)) { Tcl_Panic("%s called with shared object", "Tcl_ListObjReplace"); } - if (listPtr->typePtr != &tclListType) { - if (listPtr->bytes == tclEmptyStringRep) { - if (!objc) { + + ListGetIntRep(listPtr, listRepPtr); + if (listRepPtr == NULL) { + int length; + + (void) Tcl_GetStringFromObj(listPtr, &length); + if (length == 0) { + if (objc == 0) { return TCL_OK; } Tcl_SetListObj(listPtr, objc, NULL); @@ -875,6 +913,7 @@ Tcl_ListObjReplace( return result; } } + ListGetIntRep(listPtr, listRepPtr); } /* @@ -885,7 +924,6 @@ Tcl_ListObjReplace( * Resist any temptation to optimize this case. */ - listRepPtr = ListRepPtr(listPtr); elemPtrs = &listRepPtr->elements; numElems = listRepPtr->elemCount; @@ -939,7 +977,7 @@ Tcl_ListObjReplace( } if (newPtr) { listRepPtr = newPtr; - listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr; + ListResetIntRep(listPtr, listRepPtr); elemPtrs = &listRepPtr->elements; listRepPtr->maxElemCount = attempt; needGrow = numRequired > listRepPtr->maxElemCount; @@ -1012,7 +1050,7 @@ Tcl_ListObjReplace( } } - listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr; + ListResetIntRep(listPtr, listRepPtr); listRepPtr->refCount++; elemPtrs = &listRepPtr->elements; @@ -1127,6 +1165,7 @@ TclLindexList( int index; /* Index into the list. */ Tcl_Obj *indexListCopy; + List *listRepPtr; /* * Determine whether argPtr designates a list or a single index. We have @@ -1134,7 +1173,8 @@ TclLindexList( * shimmering; see TIP#22 and TIP#33 for the details. */ - if (argPtr->typePtr != &tclListType + ListGetIntRep(argPtr, listRepPtr); + if ((listRepPtr == NULL) && TclGetIntForIndexM(NULL , argPtr, 0, &index) == TCL_OK) { /* * argPtr designates a single index. @@ -1165,19 +1205,12 @@ TclLindexList( return TclLindexFlat(interp, listPtr, 1, &argPtr); } - if (indexListCopy->typePtr == &tclListType) { - List *listRepPtr = ListRepPtr(indexListCopy); + ListGetIntRep(indexListCopy, listRepPtr); - listPtr = TclLindexFlat(interp, listPtr, listRepPtr->elemCount, - &listRepPtr->elements); - } else { - int indexCount = -1; /* Size of the array of list indices. */ - Tcl_Obj **indices = NULL; - /* Array of list indices. */ + assert(listRepPtr != NULL); - Tcl_ListObjGetElements(NULL, indexListCopy, &indexCount, &indices); - listPtr = TclLindexFlat(interp, listPtr, indexCount, indices); - } + listPtr = TclLindexFlat(interp, listPtr, listRepPtr->elemCount, + &listRepPtr->elements); Tcl_DecrRefCount(indexListCopy); return listPtr; } @@ -1312,6 +1345,7 @@ TclLsetList( Tcl_Obj *retValuePtr; /* Pointer to the list to be returned. */ int index; /* Current index in the list - discarded. */ Tcl_Obj *indexListCopy; + List *listRepPtr; /* * Determine whether the index arg designates a list or a single index. @@ -1319,7 +1353,8 @@ TclLsetList( * shimmering; see TIP #22 and #23 for details. */ - if (indexArgPtr->typePtr != &tclListType + ListGetIntRep(indexArgPtr, listRepPtr); + if (listRepPtr == NULL && TclGetIntForIndexM(NULL, indexArgPtr, 0, &index) == TCL_OK) { /* * indexArgPtr designates a single index. @@ -1404,6 +1439,7 @@ TclLsetFlat( { int index, result, len; Tcl_Obj *subListPtr, *retValuePtr, *chainPtr; + Tcl_ObjIntRep *irPtr; /* * If there are no indices, simply return the new value. (Without @@ -1534,7 +1570,8 @@ TclLsetFlat( * them at that time. */ - parentList->internalRep.twoPtrValue.ptr2 = chainPtr; + irPtr = Tcl_FetchIntRep(parentList, &tclListType); + irPtr->twoPtrValue.ptr2 = chainPtr; chainPtr = parentList; } } while (indexCount > 0); @@ -1562,8 +1599,9 @@ TclLsetFlat( * Clear away our intrep surgery mess. */ - chainPtr = objPtr->internalRep.twoPtrValue.ptr2; - objPtr->internalRep.twoPtrValue.ptr2 = NULL; + irPtr = Tcl_FetchIntRep(objPtr, &tclListType); + chainPtr = irPtr->twoPtrValue.ptr2; + irPtr->twoPtrValue.ptr2 = NULL; } if (result != TCL_OK) { @@ -1647,10 +1685,13 @@ TclListObjSetElement( if (Tcl_IsShared(listPtr)) { Tcl_Panic("%s called with shared object", "TclListObjSetElement"); } - if (listPtr->typePtr != &tclListType) { - int result; - if (listPtr->bytes == tclEmptyStringRep) { + ListGetIntRep(listPtr, listRepPtr); + if (listRepPtr == NULL) { + int result, length; + + (void) Tcl_GetStringFromObj(listPtr, &length); + if (length == 0) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj("list index out of range", -1)); @@ -1663,9 +1704,9 @@ TclListObjSetElement( if (result != TCL_OK) { return result; } + ListGetIntRep(listPtr, listRepPtr); } - listRepPtr = ListRepPtr(listPtr); elemCount = listRepPtr->elemCount; /* @@ -1708,7 +1749,8 @@ TclListObjSetElement( listRepPtr->refCount--; - listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr = newPtr; + listRepPtr = newPtr; + ListResetIntRep(listPtr, listRepPtr); } elemPtrs = &listRepPtr->elements; @@ -1745,9 +1787,8 @@ TclListObjSetElement( * None. * * Side effects: - * Frees listPtr's List* internal representation and sets listPtr's - * internalRep.twoPtrValue.ptr1 to NULL. Decrements the ref counts of all - * element objects, which may free them. + * Frees listPtr's List* internal representation, if no longer shared. + * May decrement the ref counts of element objects, which may free them. * *---------------------------------------------------------------------- */ @@ -1756,7 +1797,10 @@ static void FreeListInternalRep( Tcl_Obj *listPtr) /* List object with internal rep to free. */ { - List *listRepPtr = ListRepPtr(listPtr); + List *listRepPtr; + + ListGetIntRep(listPtr, listRepPtr); + assert(listRepPtr != NULL); if (listRepPtr->refCount-- <= 1) { Tcl_Obj **elemPtrs = &listRepPtr->elements; @@ -1767,8 +1811,6 @@ FreeListInternalRep( } ckfree(listRepPtr); } - - listPtr->typePtr = NULL; } /* @@ -1793,8 +1835,10 @@ DupListInternalRep( Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ Tcl_Obj *copyPtr) /* Object with internal rep to set. */ { - List *listRepPtr = ListRepPtr(srcPtr); + List *listRepPtr; + ListGetIntRep(srcPtr, listRepPtr); + assert(listRepPtr != NULL); ListSetIntRep(copyPtr, listRepPtr); } @@ -1833,7 +1877,7 @@ SetListFromAny( * describe duplicate keys). */ - if (objPtr->typePtr == &tclDictType && !objPtr->bytes) { + if (Tcl_FetchIntRep(objPtr, &tclDictType) && !objPtr->bytes) { Tcl_Obj *keyPtr, *valuePtr; Tcl_DictSearch search; int done, size; @@ -1891,10 +1935,12 @@ SetListFromAny( while (nextElem < limit) { const char *elemStart; + char *check; int elemSize, literal; if (TCL_OK != TclFindElement(interp, nextElem, limit - nextElem, &elemStart, &nextElem, &elemSize, &literal)) { + fail: while (--elemPtrs >= &listRepPtr->elements) { Tcl_DecrRefCount(*elemPtrs); } @@ -1905,14 +1951,21 @@ SetListFromAny( break; } - /* TODO: replace panic with error on alloc failure? */ - if (literal) { - TclNewStringObj(*elemPtrs, elemStart, elemSize); - } else { - TclNewObj(*elemPtrs); - (*elemPtrs)->bytes = ckalloc((unsigned) elemSize + 1); - (*elemPtrs)->length = TclCopyAndCollapse(elemSize, elemStart, - (*elemPtrs)->bytes); + TclNewObj(*elemPtrs); + TclInvalidateStringRep(*elemPtrs); + check = Tcl_InitStringRep(*elemPtrs, literal ? elemStart : NULL, + elemSize); + if (elemSize && check == NULL) { + if (interp) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "cannot construct list, out of memory", -1)); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + } + goto fail; + } + if (!literal) { + Tcl_InitStringRep(*elemPtrs, NULL, + TclCopyAndCollapse(elemSize, elemStart, check)); } Tcl_IncrRefCount(*elemPtrs++);/* Since list now holds ref to it. */ @@ -1922,12 +1975,11 @@ SetListFromAny( } /* - * Free the old internalRep before setting the new one. We do this as late + * Store the new internalRep. We do this as late * as possible to allow the conversion code, in particular - * Tcl_GetStringFromObj, to use that old internalRep. + * Tcl_GetStringFromObj, to use the old internalRep. */ - TclFreeIntRep(objPtr); ListSetIntRep(objPtr, listRepPtr); return TCL_OK; } @@ -1959,12 +2011,17 @@ UpdateStringOfList( { # define LOCAL_SIZE 20 int localFlags[LOCAL_SIZE], *flagPtr = NULL; - List *listRepPtr = ListRepPtr(listPtr); - int numElems = listRepPtr->elemCount; - int i, length, bytesNeeded = 0; + int numElems, i, length, bytesNeeded = 0; const char *elem; char *dst; Tcl_Obj **elemPtrs; + List *listRepPtr; + + ListGetIntRep(listPtr, listRepPtr); + + assert(listRepPtr != NULL); + + numElems = listRepPtr->elemCount; /* * Mark the list as being canonical; although it will now have a string @@ -1979,8 +2036,7 @@ UpdateStringOfList( */ if (numElems == 0) { - listPtr->bytes = tclEmptyStringRep; - listPtr->length = 0; + Tcl_InitStringRep(listPtr, NULL, 0); return; } @@ -2009,22 +2065,21 @@ UpdateStringOfList( if (bytesNeeded > INT_MAX - numElems + 1) { Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } - bytesNeeded += numElems; + bytesNeeded += numElems - 1; /* * Pass 2: copy into string rep buffer. */ - listPtr->length = bytesNeeded - 1; - listPtr->bytes = ckalloc(bytesNeeded); - dst = listPtr->bytes; + dst = Tcl_InitStringRep(listPtr, NULL, bytesNeeded); + TclOOM(dst, bytesNeeded); for (i = 0; i < numElems; i++) { flagPtr[i] |= (i ? TCL_DONT_QUOTE_HASH : 0); elem = TclGetStringFromObj(elemPtrs[i], &length); dst += TclConvertElement(elem, length, dst, flagPtr[i]); *dst++ = ' '; } - listPtr->bytes[listPtr->length] = '\0'; + (void) Tcl_InitStringRep(listPtr, NULL, bytesNeeded); if (flagPtr != localFlags) { ckfree(flagPtr); -- cgit v0.12 From 7721fe8b51fce18f525df0bbf8328e84ce97c693 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 30 Mar 2016 17:15:44 +0000 Subject: Remove direct access to Tcl_Obj typePtr field that does nothing of any obvious benefit. --- generic/tclTimer.c | 14 ++++---------- 1 file changed, 4 insertions(+), 10 deletions(-) diff --git a/generic/tclTimer.c b/generic/tclTimer.c index c10986a..d819657 100644 --- a/generic/tclTimer.c +++ b/generic/tclTimer.c @@ -789,7 +789,7 @@ Tcl_AfterObjCmd( AfterInfo *afterPtr; AfterAssocData *assocPtr; int length; - int index; + int index = -1; static const char *const afterSubCmds[] = { "cancel", "idle", "info", NULL }; @@ -818,15 +818,9 @@ Tcl_AfterObjCmd( * First lets see if the command was passed a number as the first argument. */ - if (objv[1]->typePtr == &tclIntType -#ifndef TCL_WIDE_INT_IS_LONG - || objv[1]->typePtr == &tclWideIntType -#endif - || objv[1]->typePtr == &tclBignumType - || (Tcl_GetIndexFromObj(NULL, objv[1], afterSubCmds, "", 0, - &index) != TCL_OK)) { - index = -1; - if (Tcl_GetWideIntFromObj(NULL, objv[1], &ms) != TCL_OK) { + if (Tcl_GetWideIntFromObj(NULL, objv[1], &ms) != TCL_OK) { + if (Tcl_GetIndexFromObj(NULL, objv[1], afterSubCmds, "", 0, &index) + != TCL_OK) { const char *arg = Tcl_GetString(objv[1]); Tcl_SetObjResult(interp, Tcl_ObjPrintf( -- cgit v0.12 From 0a4081dc5704449a007440e97a84df6dda5baf02 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 30 Mar 2016 17:55:59 +0000 Subject: Revise several ACCEPT_NAN stanzas. --- generic/tclBasic.c | 79 +++++++++++++++++++++++++++++++++++++----------------- generic/tclLink.c | 5 ++-- generic/tclScan.c | 6 +++-- 3 files changed, 61 insertions(+), 29 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 505f6c2..0a20323 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -3513,9 +3513,14 @@ OldMathFuncProc( valuePtr = objv[j]; result = Tcl_GetDoubleFromObj(NULL, valuePtr, &d); #ifdef ACCEPT_NAN - if ((result != TCL_OK) && (valuePtr->typePtr == &tclDoubleType)) { - d = valuePtr->internalRep.doubleValue; - result = TCL_OK; + if (result != TCL_OK) { + const Tcl_ObjIntRep *irPtr + = Tcl_FetchIntRep(valuePtr, &tclDoubleType); + + if (irPtr) { + d = irPtr->doubleValue; + result = TCL_OK; + } } #endif if (result != TCL_OK) { @@ -7061,9 +7066,13 @@ ExprCeilFunc( } code = Tcl_GetDoubleFromObj(interp, objv[1], &d); #ifdef ACCEPT_NAN - if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) { - Tcl_SetObjResult(interp, objv[1]); - return TCL_OK; + if (code != TCL_OK) { + const Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(objv[1], &tclDoubleType); + + if (irPtr) { + Tcl_SetObjResult(interp, objv[1]); + return TCL_OK; + } } #endif if (code != TCL_OK) { @@ -7097,9 +7106,13 @@ ExprFloorFunc( } code = Tcl_GetDoubleFromObj(interp, objv[1], &d); #ifdef ACCEPT_NAN - if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) { - Tcl_SetObjResult(interp, objv[1]); - return TCL_OK; + if (code != TCL_OK) { + const Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(objv[1], &tclDoubleType); + + if (irPtr) { + Tcl_SetObjResult(interp, objv[1]); + return TCL_OK; + } } #endif if (code != TCL_OK) { @@ -7233,9 +7246,13 @@ ExprSqrtFunc( } code = Tcl_GetDoubleFromObj(interp, objv[1], &d); #ifdef ACCEPT_NAN - if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) { - Tcl_SetObjResult(interp, objv[1]); - return TCL_OK; + if (code != TCL_OK) { + const Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(objv[1], &tclDoubleType); + + if (irPtr) { + Tcl_SetObjResult(interp, objv[1]); + return TCL_OK; + } } #endif if (code != TCL_OK) { @@ -7276,10 +7293,14 @@ ExprUnaryFunc( } code = Tcl_GetDoubleFromObj(interp, objv[1], &d); #ifdef ACCEPT_NAN - if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) { - d = objv[1]->internalRep.doubleValue; - Tcl_ResetResult(interp); - code = TCL_OK; + if (code != TCL_OK) { + const Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(objv[1], &tclDoubleType); + + if (irPtr) { + d = irPtr->doubleValue; + Tcl_ResetResult(interp); + code = TCL_OK; + } } #endif if (code != TCL_OK) { @@ -7336,10 +7357,14 @@ ExprBinaryFunc( } code = Tcl_GetDoubleFromObj(interp, objv[1], &d1); #ifdef ACCEPT_NAN - if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) { - d1 = objv[1]->internalRep.doubleValue; - Tcl_ResetResult(interp); - code = TCL_OK; + if (code != TCL_OK) { + const Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(objv[1], &tclDoubleType); + + if (irPtr) { + d1 = irPtr->doubleValue; + Tcl_ResetResult(interp); + code = TCL_OK; + } } #endif if (code != TCL_OK) { @@ -7347,10 +7372,14 @@ ExprBinaryFunc( } code = Tcl_GetDoubleFromObj(interp, objv[2], &d2); #ifdef ACCEPT_NAN - if ((code != TCL_OK) && (objv[2]->typePtr == &tclDoubleType)) { - d2 = objv[2]->internalRep.doubleValue; - Tcl_ResetResult(interp); - code = TCL_OK; + if (code != TCL_OK) { + const Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(objv[1], &tclDoubleType); + + if (irPtr) { + d2 = irPtr->doubleValue; + Tcl_ResetResult(interp); + code = TCL_OK; + } } #endif if (code != TCL_OK) { @@ -7506,7 +7535,7 @@ ExprDoubleFunc( } if (Tcl_GetDoubleFromObj(interp, objv[1], &dResult) != TCL_OK) { #ifdef ACCEPT_NAN - if (objv[1]->typePtr == &tclDoubleType) { + if (Tcl_FetchIntRep(objv[1], &tclDoubleType)) { Tcl_SetObjResult(interp, objv[1]); return TCL_OK; } diff --git a/generic/tclLink.c b/generic/tclLink.c index 2735256..27bd490 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -401,14 +401,15 @@ LinkTraceProc( if (Tcl_GetDoubleFromObj(NULL, valueObj, &linkPtr->lastValue.d) != TCL_OK) { #ifdef ACCEPT_NAN - if (valueObj->typePtr != &tclDoubleType) { + Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(valueObj, &tclDoubleType); + if (irPtr == NULL) { #endif Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); return (char *) "variable must have real value"; #ifdef ACCEPT_NAN } - linkPtr->lastValue.d = valueObj->internalRep.doubleValue; + linkPtr->lastValue.d = irPtr->doubleValue; #endif } LinkedVar(double) = linkPtr->lastValue.d; diff --git a/generic/tclScan.c b/generic/tclScan.c index 3edb8be..735cd15 100644 --- a/generic/tclScan.c +++ b/generic/tclScan.c @@ -984,8 +984,10 @@ Tcl_ScanObjCmd( double dvalue; if (Tcl_GetDoubleFromObj(NULL, objPtr, &dvalue) != TCL_OK) { #ifdef ACCEPT_NAN - if (objPtr->typePtr == &tclDoubleType) { - dvalue = objPtr->internalRep.doubleValue; + const Tcl_ObjIntRep *irPtr + = Tcl_FetchIntRep(objPtr, &tclDoubleType); + if (irPtr) { + dvalue = irPtr->doubleValue; } else #endif { -- cgit v0.12 From 1dc5de01791dc98bb90e169012ff9cebee4fe0cd Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 30 Mar 2016 23:16:21 +0000 Subject: Revise "dict" Tcl_ObjType to use proposed routines. --- generic/tclDictObj.c | 183 ++++++++++++++++++++++++++++----------------------- 1 file changed, 99 insertions(+), 84 deletions(-) diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index 6e54137..da18a2b 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -12,6 +12,7 @@ #include "tclInt.h" #include "tommath.h" +#include /* * Forward declaration. @@ -155,13 +156,6 @@ typedef struct Dict { } Dict; /* - * Accessor macro for converting between a Tcl_Obj* and a Dict. Note that this - * must be assignable as well as readable. - */ - -#define DICT(dictObj) (*((Dict **)&(dictObj)->internalRep.twoPtrValue.ptr1)) - -/* * The structure below defines the dictionary object type by means of * functions that can be invoked by generic object code. */ @@ -174,6 +168,21 @@ const Tcl_ObjType tclDictType = { SetDictFromAny /* setFromAnyProc */ }; +#define DictSetIntRep(objPtr, dictRepPtr) \ + do { \ + Tcl_ObjIntRep ir; \ + ir.twoPtrValue.ptr1 = (dictRepPtr); \ + ir.twoPtrValue.ptr2 = NULL; \ + Tcl_StoreIntRep((objPtr), &tclDictType, &ir); \ + } while (0) + +#define DictGetIntRep(objPtr, dictRepPtr) \ + do { \ + const Tcl_ObjIntRep *irPtr; \ + irPtr = Tcl_FetchIntRep((objPtr), &tclDictType); \ + (dictRepPtr) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \ + } while (0) + /* * The type of the specially adapted version of the Tcl_Obj*-containing hash * table defined in the tclObj.c code. This version differs in that it @@ -369,10 +378,11 @@ DupDictInternalRep( Tcl_Obj *srcPtr, Tcl_Obj *copyPtr) { - Dict *oldDict = DICT(srcPtr); - Dict *newDict = ckalloc(sizeof(Dict)); + Dict *oldDict, *newDict = ckalloc(sizeof(Dict)); ChainEntry *cPtr; + DictGetIntRep(srcPtr, oldDict); + /* * Copy values across from the old hash table. */ @@ -404,9 +414,7 @@ DupDictInternalRep( * Store in the object. */ - DICT(copyPtr) = newDict; - copyPtr->internalRep.twoPtrValue.ptr2 = NULL; - copyPtr->typePtr = &tclDictType; + DictSetIntRep(copyPtr, newDict); } /* @@ -431,13 +439,14 @@ static void FreeDictInternalRep( Tcl_Obj *dictPtr) { - Dict *dict = DICT(dictPtr); + Dict *dict; + + DictGetIntRep(dictPtr, dict); dict->refcount--; if (dict->refcount <= 0) { DeleteDict(dict); } - dictPtr->typePtr = NULL; } /* @@ -496,7 +505,7 @@ UpdateStringOfDict( { #define LOCAL_SIZE 20 int localFlags[LOCAL_SIZE], *flagPtr = NULL; - Dict *dict = DICT(dictPtr); + Dict *dict; ChainEntry *cPtr; Tcl_Obj *keyPtr, *valuePtr; int i, length, bytesNeeded = 0; @@ -509,7 +518,13 @@ UpdateStringOfDict( * is not exposed by any API function... */ - int numElems = dict->table.numEntries * 2; + int numElems; + + DictGetIntRep(dictPtr, dict); + + assert (dict != NULL); + + numElems = dict->table.numEntries * 2; /* Handle empty list case first, simplifies what follows */ if (numElems == 0) { @@ -722,13 +737,10 @@ SetDictFromAny( * Tcl_GetStringFromObj, to use that old internalRep. */ - TclFreeIntRep(objPtr); dict->epoch = 0; dict->chain = NULL; dict->refcount = 1; - DICT(objPtr) = dict; - objPtr->internalRep.twoPtrValue.ptr2 = NULL; - objPtr->typePtr = &tclDictType; + DictSetIntRep(objPtr, dict); return TCL_OK; missingValue: @@ -742,6 +754,23 @@ SetDictFromAny( ckfree(dict); return TCL_ERROR; } + +static Dict * +GetDictFromObj( + Tcl_Interp *interp, + Tcl_Obj *dictPtr) +{ + Dict *dict; + + DictGetIntRep(dictPtr, dict); + if (dict == NULL) { + if (SetDictFromAny(interp, dictPtr) != TCL_OK) { + return NULL; + } + DictGetIntRep(dictPtr, dict); + } + return dict; +} /* *---------------------------------------------------------------------- @@ -786,11 +815,13 @@ TclTraceDictPath( Dict *dict, *newDict; int i; - if (dictPtr->typePtr != &tclDictType - && SetDictFromAny(interp, dictPtr) != TCL_OK) { - return NULL; + DictGetIntRep(dictPtr, dict); + if (dict == NULL) { + if (SetDictFromAny(interp, dictPtr) != TCL_OK) { + return NULL; + } + DictGetIntRep(dictPtr, dict); } - dict = DICT(dictPtr); if (flags & DICT_PATH_UPDATE) { dict->chain = NULL; } @@ -826,13 +857,17 @@ TclTraceDictPath( Tcl_SetHashValue(hPtr, tmpObj); } else { tmpObj = Tcl_GetHashValue(hPtr); - if (tmpObj->typePtr != &tclDictType - && SetDictFromAny(interp, tmpObj) != TCL_OK) { - return NULL; + + DictGetIntRep(tmpObj, newDict); + + if (newDict == NULL) { + if (SetDictFromAny(interp, tmpObj) != TCL_OK) { + return NULL; + } } } - newDict = DICT(tmpObj); + DictGetIntRep(tmpObj, newDict); if (flags & DICT_PATH_UPDATE) { if (Tcl_IsShared(tmpObj)) { TclDecrRefCount(tmpObj); @@ -840,7 +875,7 @@ TclTraceDictPath( Tcl_IncrRefCount(tmpObj); Tcl_SetHashValue(hPtr, tmpObj); dict->epoch++; - newDict = DICT(tmpObj); + DictGetIntRep(tmpObj, newDict); } newDict->chain = dictPtr; @@ -875,7 +910,10 @@ static void InvalidateDictChain( Tcl_Obj *dictObj) { - Dict *dict = DICT(dictObj); + Dict *dict; + + DictGetIntRep(dictObj, dict); + assert( dict != NULL); do { TclInvalidateStringRep(dictObj); @@ -885,7 +923,7 @@ InvalidateDictChain( break; } dict->chain = NULL; - dict = DICT(dictObj); + DictGetIntRep(dictObj, dict); } while (dict != NULL); } @@ -923,15 +961,12 @@ Tcl_DictObjPut( Tcl_Panic("%s called with shared object", "Tcl_DictObjPut"); } - if (dictPtr->typePtr != &tclDictType - && SetDictFromAny(interp, dictPtr) != TCL_OK) { + dict = GetDictFromObj(interp, dictPtr); + if (dict == NULL) { return TCL_ERROR; } - if (dictPtr->bytes != NULL) { - TclInvalidateStringRep(dictPtr); - } - dict = DICT(dictPtr); + TclInvalidateStringRep(dictPtr); hPtr = CreateChainEntry(dict, keyPtr, &isNew); Tcl_IncrRefCount(valuePtr); if (!isNew) { @@ -974,13 +1009,12 @@ Tcl_DictObjGet( Dict *dict; Tcl_HashEntry *hPtr; - if (dictPtr->typePtr != &tclDictType - && SetDictFromAny(interp, dictPtr) != TCL_OK) { + dict = GetDictFromObj(interp, dictPtr); + if (dict == NULL) { *valuePtrPtr = NULL; return TCL_ERROR; } - dict = DICT(dictPtr); hPtr = Tcl_FindHashEntry(&dict->table, keyPtr); if (hPtr == NULL) { *valuePtrPtr = NULL; @@ -1021,16 +1055,13 @@ Tcl_DictObjRemove( Tcl_Panic("%s called with shared object", "Tcl_DictObjRemove"); } - if (dictPtr->typePtr != &tclDictType - && SetDictFromAny(interp, dictPtr) != TCL_OK) { + dict = GetDictFromObj(interp, dictPtr); + if (dict == NULL) { return TCL_ERROR; } - dict = DICT(dictPtr); if (DeleteChainEntry(dict, keyPtr)) { - if (dictPtr->bytes != NULL) { - TclInvalidateStringRep(dictPtr); - } + TclInvalidateStringRep(dictPtr); dict->epoch++; } return TCL_OK; @@ -1062,12 +1093,11 @@ Tcl_DictObjSize( { Dict *dict; - if (dictPtr->typePtr != &tclDictType - && SetDictFromAny(interp, dictPtr) != TCL_OK) { + dict = GetDictFromObj(interp, dictPtr); + if (dict == NULL) { return TCL_ERROR; } - dict = DICT(dictPtr); *sizePtr = dict->table.numEntries; return TCL_OK; } @@ -1114,12 +1144,11 @@ Tcl_DictObjFirst( Dict *dict; ChainEntry *cPtr; - if (dictPtr->typePtr != &tclDictType - && SetDictFromAny(interp, dictPtr) != TCL_OK) { + dict = GetDictFromObj(interp, dictPtr); + if (dict == NULL) { return TCL_ERROR; } - dict = DICT(dictPtr); cPtr = dict->entryChainHead; if (cPtr == NULL) { searchPtr->epoch = -1; @@ -1294,7 +1323,8 @@ Tcl_DictObjPutKeyList( return TCL_ERROR; } - dict = DICT(dictPtr); + DictGetIntRep(dictPtr, dict); + assert(dict != NULL); hPtr = CreateChainEntry(dict, keyv[keyc-1], &isNew); Tcl_IncrRefCount(valuePtr); if (!isNew) { @@ -1351,7 +1381,8 @@ Tcl_DictObjRemoveKeyList( return TCL_ERROR; } - dict = DICT(dictPtr); + DictGetIntRep(dictPtr, dict); + assert(dict != NULL); DeleteChainEntry(dict, keyv[keyc-1]); InvalidateDictChain(dictPtr); return TCL_OK; @@ -1397,9 +1428,7 @@ Tcl_NewDictObj(void) dict->epoch = 0; dict->chain = NULL; dict->refcount = 1; - DICT(dictPtr) = dict; - dictPtr->internalRep.twoPtrValue.ptr2 = NULL; - dictPtr->typePtr = &tclDictType; + DictSetIntRep(dictPtr, dict); return dictPtr; #endif } @@ -1447,9 +1476,7 @@ Tcl_DbNewDictObj( dict->epoch = 0; dict->chain = NULL; dict->refcount = 1; - DICT(dictPtr) = dict; - dictPtr->internalRep.twoPtrValue.ptr2 = NULL; - dictPtr->typePtr = &tclDictType; + DictSetIntRep(dictPtr, dict); return dictPtr; #else /* !TCL_MEM_DEBUG */ return Tcl_NewDictObj(); @@ -1635,16 +1662,13 @@ DictReplaceCmd( } dictPtr = objv[1]; - if (dictPtr->typePtr != &tclDictType - && SetDictFromAny(interp, dictPtr) != TCL_OK) { + if (GetDictFromObj(interp, dictPtr) == NULL) { return TCL_ERROR; } if (Tcl_IsShared(dictPtr)) { dictPtr = Tcl_DuplicateObj(dictPtr); } - if (dictPtr->bytes != NULL) { - TclInvalidateStringRep(dictPtr); - } + TclInvalidateStringRep(dictPtr); for (i=2 ; itypePtr != &tclDictType - && SetDictFromAny(interp, dictPtr) != TCL_OK) { + if (GetDictFromObj(interp, dictPtr) == NULL) { return TCL_ERROR; } if (Tcl_IsShared(dictPtr)) { dictPtr = Tcl_DuplicateObj(dictPtr); } - if (dictPtr->bytes != NULL) { - TclInvalidateStringRep(dictPtr); - } + TclInvalidateStringRep(dictPtr); for (i=2 ; itypePtr != &tclDictType - && SetDictFromAny(interp, targetObj) != TCL_OK) { + if (GetDictFromObj(interp, targetObj) == NULL) { return TCL_ERROR; } @@ -1830,8 +1850,7 @@ DictKeysCmd( * need. [Bug 1705778, leak K04] */ - if (objv[1]->typePtr != &tclDictType - && SetDictFromAny(interp, objv[1]) != TCL_OK) { + if (GetDictFromObj(interp, objv[1]) == NULL) { return TCL_ERROR; } @@ -2038,7 +2057,6 @@ DictInfoCmd( int objc, Tcl_Obj *const *objv) { - Tcl_Obj *dictPtr; Dict *dict; char *statsStr; @@ -2047,12 +2065,10 @@ DictInfoCmd( return TCL_ERROR; } - dictPtr = objv[1]; - if (dictPtr->typePtr != &tclDictType - && SetDictFromAny(interp, dictPtr) != TCL_OK) { + dict = GetDictFromObj(interp, objv[1]); + if (dict == NULL) { return TCL_ERROR; } - dict = DICT(dictPtr); statsStr = Tcl_HashStats(&dict->table); Tcl_SetObjResult(interp, Tcl_NewStringObj(statsStr, -1)); @@ -2113,12 +2129,11 @@ DictIncrCmd( * soon be no good. */ - char *saved = dictPtr->bytes; Tcl_Obj *oldPtr = dictPtr; - dictPtr->bytes = NULL; - dictPtr = Tcl_DuplicateObj(dictPtr); - oldPtr->bytes = saved; + TclNewObj(dictPtr); + TclInvalidateStringRep(dictPtr); + DupDictInternalRep(oldPtr, dictPtr); } if (valuePtr == NULL) { /* @@ -2255,7 +2270,7 @@ DictLappendCmd( if (allocatedValue) { Tcl_DictObjPut(NULL, dictPtr, objv[2], valuePtr); - } else if (dictPtr->bytes != NULL) { + } else { TclInvalidateStringRep(dictPtr); } -- cgit v0.12 From e51db8046c91bb1eec29754bf40f5f5cbd3c7ca9 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 4 Apr 2016 17:27:24 +0000 Subject: Revise "regexp" Tcl_ObjType to use proposed routines. --- generic/tclRegexp.c | 60 ++++++++++++++++++++++++++++------------------------- 1 file changed, 32 insertions(+), 28 deletions(-) diff --git a/generic/tclRegexp.c b/generic/tclRegexp.c index ea25d4b..6845f7d 100644 --- a/generic/tclRegexp.c +++ b/generic/tclRegexp.c @@ -13,6 +13,7 @@ #include "tclInt.h" #include "tclRegexp.h" +#include /* *---------------------------------------------------------------------- @@ -107,6 +108,23 @@ const Tcl_ObjType tclRegexpType = { NULL, /* updateStringProc */ SetRegexpFromAny /* setFromAnyProc */ }; + +#define RegexpSetIntRep(objPtr, rePtr) \ + do { \ + Tcl_ObjIntRep ir; \ + (rePtr)->refCount++; \ + ir.twoPtrValue.ptr1 = (rePtr); \ + ir.twoPtrValue.ptr2 = NULL; \ + Tcl_StoreIntRep((objPtr), &tclRegexpType, &ir); \ + } while (0) + +#define RegexpGetIntRep(objPtr, rePtr) \ + do { \ + const Tcl_ObjIntRep *irPtr; \ + irPtr = Tcl_FetchIntRep((objPtr), &tclRegexpType); \ + (rePtr) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \ + } while (0) + /* *---------------------------------------------------------------------- @@ -573,14 +591,9 @@ Tcl_GetRegExpFromObj( TclRegexp *regexpPtr; const char *pattern; - /* - * This is OK because we only actually interpret this value properly as a - * TclRegexp* when the type is tclRegexpType. - */ - - regexpPtr = objPtr->internalRep.twoPtrValue.ptr1; + RegexpGetIntRep(objPtr, regexpPtr); - if ((objPtr->typePtr != &tclRegexpType) || (regexpPtr->flags != flags)) { + if ((regexpPtr == NULL) || (regexpPtr->flags != flags)) { pattern = TclGetStringFromObj(objPtr, &length); regexpPtr = CompileRegexp(interp, pattern, length, flags); @@ -588,21 +601,7 @@ Tcl_GetRegExpFromObj( return NULL; } - /* - * Add a reference to the regexp so it will persist even if it is - * pushed out of the current thread's regexp cache. This reference - * will be removed when the object's internal rep is freed. - */ - - regexpPtr->refCount++; - - /* - * Free the old representation and set our type. - */ - - TclFreeIntRep(objPtr); - objPtr->internalRep.twoPtrValue.ptr1 = regexpPtr; - objPtr->typePtr = &tclRegexpType; + RegexpSetIntRep(objPtr, regexpPtr); } return (Tcl_RegExp) regexpPtr; } @@ -749,7 +748,11 @@ static void FreeRegexpInternalRep( Tcl_Obj *objPtr) /* Regexp object with internal rep to free. */ { - TclRegexp *regexpRepPtr = objPtr->internalRep.twoPtrValue.ptr1; + TclRegexp *regexpRepPtr; + + RegexpGetIntRep(objPtr, regexpRepPtr); + + assert(regexpRepPtr != NULL); /* * If this is the last reference to the regexp, free it. @@ -758,7 +761,6 @@ FreeRegexpInternalRep( if (regexpRepPtr->refCount-- <= 1) { FreeRegexp(regexpRepPtr); } - objPtr->typePtr = NULL; } /* @@ -783,11 +785,13 @@ DupRegexpInternalRep( Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ Tcl_Obj *copyPtr) /* Object with internal rep to set. */ { - TclRegexp *regexpPtr = srcPtr->internalRep.twoPtrValue.ptr1; + TclRegexp *regexpPtr; + + RegexpGetIntRep(srcPtr, regexpPtr); + + assert(regexpPtr != NULL); - regexpPtr->refCount++; - copyPtr->internalRep.twoPtrValue.ptr1 = srcPtr->internalRep.twoPtrValue.ptr1; - copyPtr->typePtr = &tclRegexpType; + RegexpSetIntRep(copyPtr, regexpPtr); } /* -- cgit v0.12 From aec00dd13c8809b024155d124c3e2bc67c947df9 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 4 Apr 2016 17:43:32 +0000 Subject: Revise "instname" ObjType to use proposed routines --- generic/tclDisassemble.c | 31 ++++++++++++++++++++++++------- 1 file changed, 24 insertions(+), 7 deletions(-) diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index ecd5f38..73a7815 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -39,7 +39,7 @@ static void UpdateStringOfInstName(Tcl_Obj *objPtr); * reporting of inner contexts in errorstack without string allocation. */ -static const Tcl_ObjType tclInstNameType = { +static const Tcl_ObjType instNameType = { "instname", /* name */ NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ @@ -47,6 +47,21 @@ static const Tcl_ObjType tclInstNameType = { NULL, /* setFromAnyProc */ }; +#define InstNameSetIntRep(objPtr, inst) \ + do { \ + Tcl_ObjIntRep ir; \ + ir.longValue = (inst); \ + Tcl_StoreIntRep((objPtr), &instNameType, &ir); \ + } while (0) + +#define InstNameGetIntRep(objPtr, inst) \ + do { \ + const Tcl_ObjIntRep *irPtr; \ + irPtr = Tcl_FetchIntRep((objPtr), &instNameType); \ + assert(irPtr != NULL); \ + (inst) = irPtr->longValue; \ + } while (0) + /* * How to get the bytecode out of a Tcl_Obj. */ @@ -802,11 +817,11 @@ TclNewInstNameObj( { Tcl_Obj *objPtr = Tcl_NewObj(); - objPtr->typePtr = &tclInstNameType; - objPtr->internalRep.longValue = (long) inst; /* Optimized Tcl_InvalidateStringRep */ objPtr->bytes = NULL; + InstNameSetIntRep(objPtr, (long) inst); + return objPtr; } @@ -824,16 +839,18 @@ static void UpdateStringOfInstName( Tcl_Obj *objPtr) { - int inst = objPtr->internalRep.longValue; + int inst; char *dst; + InstNameGetIntRep(objPtr, inst); + if ((inst < 0) || (inst > LAST_INST_OPCODE)) { - dst = Tcl_InitStringRep(objPtr, NULL, TCL_INTEGER_SPACE + 4); - TclOOM(dst, TCL_INTEGER_SPACE + 4); + dst = Tcl_InitStringRep(objPtr, NULL, TCL_INTEGER_SPACE + 5); + TclOOM(dst, TCL_INTEGER_SPACE + 5); sprintf(dst, "inst_%d", inst); (void) Tcl_InitStringRep(objPtr, NULL, strlen(dst)); } else { - const char *s = tclInstructionTable[objPtr->internalRep.longValue].name; + const char *s = tclInstructionTable[inst].name; int len = strlen(s); dst = Tcl_InitStringRep(objPtr, s, len); TclOOM(dst, len); -- cgit v0.12 From 6661778d6e9f121c214b29a9011fbd884fc59b8c Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 4 Apr 2016 18:12:42 +0000 Subject: Revise "nsName" ObjType to use proposed routines. --- generic/tclNamesp.c | 65 +++++++++++++++++++++++++++++++---------------------- 1 file changed, 38 insertions(+), 27 deletions(-) diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index dfab185..81d2f80 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -25,6 +25,7 @@ #include "tclInt.h" #include "tclCompile.h" /* for TclLogCommandInfo visibility */ +#include /* * Thread-local storage used to avoid having a global lock on data that is not @@ -154,6 +155,22 @@ static const Tcl_ObjType nsNameType = { SetNsNameFromAny /* setFromAnyProc */ }; +#define NsNameSetIntRep(objPtr, nnPtr) \ + do { \ + Tcl_ObjIntRep ir; \ + (nnPtr)->refCount++; \ + ir.twoPtrValue.ptr1 = (nnPtr); \ + ir.twoPtrValue.ptr2 = NULL; \ + Tcl_StoreIntRep((objPtr), &nsNameType, &ir); \ + } while (0) + +#define NsNameGetIntRep(objPtr, nnPtr) \ + do { \ + const Tcl_ObjIntRep *irPtr; \ + irPtr = Tcl_FetchIntRep((objPtr), &nsNameType); \ + (nnPtr) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \ + } while (0) + /* * Array of values describing how to implement each standard subcommand of the * "namespace" command. @@ -2830,15 +2847,16 @@ GetNamespaceFromObj( Tcl_Namespace **nsPtrPtr) /* Result namespace pointer goes here. */ { ResolvedNsName *resNamePtr; - Namespace *nsPtr, *refNsPtr; - if (objPtr->typePtr == &nsNameType) { + NsNameGetIntRep(objPtr, resNamePtr); + if (resNamePtr) { + Namespace *nsPtr, *refNsPtr; + /* * Check that the ResolvedNsName is still valid; avoid letting the ref * cross interps. */ - resNamePtr = objPtr->internalRep.twoPtrValue.ptr1; nsPtr = resNamePtr->nsPtr; refNsPtr = resNamePtr->refNsPtr; if (!(nsPtr->flags & NS_DYING) && (interp == nsPtr->interp) && @@ -2847,9 +2865,11 @@ GetNamespaceFromObj( *nsPtrPtr = (Tcl_Namespace *) nsPtr; return TCL_OK; } + TclFreeIntRep(objPtr); } if (SetNsNameFromAny(interp, objPtr) == TCL_OK) { - resNamePtr = objPtr->internalRep.twoPtrValue.ptr1; + NsNameGetIntRep(objPtr, resNamePtr); + assert(resNamePtr != NULL); *nsPtrPtr = (Tcl_Namespace *) resNamePtr->nsPtr; return TCL_OK; } @@ -4634,8 +4654,11 @@ FreeNsNameInternalRep( register Tcl_Obj *objPtr) /* nsName object with internal representation * to free. */ { - ResolvedNsName *resNamePtr = objPtr->internalRep.twoPtrValue.ptr1; + ResolvedNsName *resNamePtr; + NsNameGetIntRep(objPtr, resNamePtr); + assert(resNamePtr != NULL); + /* * Decrement the reference count of the namespace. If there are no more * references, free it up. @@ -4652,7 +4675,6 @@ FreeNsNameInternalRep( TclNsDecrRefCount(resNamePtr->nsPtr); ckfree(resNamePtr); } - objPtr->typePtr = NULL; } /* @@ -4679,11 +4701,11 @@ DupNsNameInternalRep( Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ register Tcl_Obj *copyPtr) /* Object with internal rep to set. */ { - ResolvedNsName *resNamePtr = srcPtr->internalRep.twoPtrValue.ptr1; + ResolvedNsName *resNamePtr; - copyPtr->internalRep.twoPtrValue.ptr1 = resNamePtr; - resNamePtr->refCount++; - copyPtr->typePtr = &nsNameType; + NsNameGetIntRep(srcPtr, resNamePtr); + assert(resNamePtr != NULL); + NsNameSetIntRep(copyPtr, resNamePtr); } /* @@ -4728,24 +4750,15 @@ SetNsNameFromAny( TclGetNamespaceForQualName(interp, name, NULL, TCL_FIND_ONLY_NS, &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy); + if ((nsPtr == NULL) || (nsPtr->flags & NS_DYING)) { + return TCL_ERROR; + } + /* * If we found a namespace, then create a new ResolvedNsName structure * that holds a reference to it. */ - if ((nsPtr == NULL) || (nsPtr->flags & NS_DYING)) { - /* - * Our failed lookup proves any previously cached nsName intrep is no - * longer valid. Get rid of it so we no longer waste memory storing - * it, nor time determining its invalidity again and again. - */ - - if (objPtr->typePtr == &nsNameType) { - TclFreeIntRep(objPtr); - } - return TCL_ERROR; - } - nsPtr->refCount++; resNamePtr = ckalloc(sizeof(ResolvedNsName)); resNamePtr->nsPtr = nsPtr; @@ -4754,10 +4767,8 @@ SetNsNameFromAny( } else { resNamePtr->refNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); } - resNamePtr->refCount = 1; - TclFreeIntRep(objPtr); - objPtr->internalRep.twoPtrValue.ptr1 = resNamePtr; - objPtr->typePtr = &nsNameType; + resNamePtr->refCount = 0; + NsNameSetIntRep(objPtr, resNamePtr); return TCL_OK; } -- cgit v0.12 From cbfce81f380db6f7472982384457409f58537747 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 4 Apr 2016 19:41:07 +0000 Subject: Use simple name for file static struct. --- generic/tclVar.c | 20 ++++++++------------ 1 file changed, 8 insertions(+), 12 deletions(-) diff --git a/generic/tclVar.c b/generic/tclVar.c index be035f7..a05bcf8 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -218,10 +218,6 @@ static Tcl_SetFromAnyProc PanicOnSetVarName; * or NULL if it is this same obj * twoPtrValue.ptr2: index into locals table * - * nsVarName - INTERNALREP DEFINITION: - * twoPtrValue.ptr1: pointer to the namespace containing the reference - * twoPtrValue.ptr2: pointer to the corresponding Var - * * parsedVarName - INTERNALREP DEFINITION: * twoPtrValue.ptr1: pointer to the array name Tcl_Obj, or NULL if it is a * scalar variable @@ -234,7 +230,7 @@ static const Tcl_ObjType localVarNameType = { FreeLocalVarName, DupLocalVarName, PanicOnUpdateVarName, PanicOnSetVarName }; -static const Tcl_ObjType tclParsedVarNameType = { +static const Tcl_ObjType parsedVarNameType = { "parsedVarName", FreeParsedVarName, DupParsedVarName, PanicOnUpdateVarName, PanicOnSetVarName }; @@ -442,7 +438,7 @@ TclLookupVar( * Side effects: * New hashtable entries may be created if createPart1 or createPart2 * are 1. The object part1Ptr is converted to one of localVarNameType, - * tclNsVarNameType or tclParsedVarNameType and caches as much of the + * tclNsVarNameType or parsedVarNameType and caches as much of the * lookup as it can. * When createPart1 is 1, callers must IncrRefCount part1Ptr if they * plan to DecrRefCount it. @@ -562,11 +558,11 @@ TclObjLookupVarEx( } /* - * If part1Ptr is a tclParsedVarNameType, separate it into the pre-parsed + * If part1Ptr is a parsedVarNameType, separate it into the pre-parsed * parts. */ - if (typePtr == &tclParsedVarNameType) { + if (typePtr == &parsedVarNameType) { if (part1Ptr->internalRep.twoPtrValue.ptr1 != NULL) { if (part2Ptr != NULL) { /* @@ -632,12 +628,12 @@ TclObjLookupVarEx( /* * Free the internal rep of the original part1Ptr, now renamed - * objPtr, and set it to tclParsedVarNameType. + * objPtr, and set it to parsedVarNameType. */ objPtr = part1Ptr; TclFreeIntRep(objPtr); - objPtr->typePtr = &tclParsedVarNameType; + objPtr->typePtr = &parsedVarNameType; /* * Define a new string object to hold the new part1Ptr, i.e., @@ -706,7 +702,7 @@ TclObjLookupVarEx( * At least mark part1Ptr as already parsed. */ - part1Ptr->typePtr = &tclParsedVarNameType; + part1Ptr->typePtr = &parsedVarNameType; part1Ptr->internalRep.twoPtrValue.ptr1 = NULL; part1Ptr->internalRep.twoPtrValue.ptr2 = NULL; } @@ -5603,7 +5599,7 @@ DupParsedVarName( dupPtr->internalRep.twoPtrValue.ptr1 = arrayPtr; dupPtr->internalRep.twoPtrValue.ptr2 = elem; - dupPtr->typePtr = &tclParsedVarNameType; + dupPtr->typePtr = &parsedVarNameType; } /* -- cgit v0.12 From 90bb5bf23c75bf9403f3d485964e4f14cc203a05 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 4 Apr 2016 22:00:02 +0000 Subject: Use new routine TclGetLambdaFromObj to better isolate the "lambdaExpr" ObjType. Then convert it to use the proposed routines. --- generic/tclDisassemble.c | 16 ++------ generic/tclInt.h | 2 + generic/tclProc.c | 100 +++++++++++++++++++++++++++++++---------------- 3 files changed, 72 insertions(+), 46 deletions(-) diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index 73a7815..83e950a 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -1325,27 +1325,19 @@ Tcl_DisassembleObjCmd( /* * Compile (if uncompiled) and disassemble a lambda term. - * - * WARNING! Pokes inside the lambda objtype. */ if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "lambdaTerm"); return TCL_ERROR; } - if (objv[2]->typePtr == &tclLambdaType) { - procPtr = objv[2]->internalRep.twoPtrValue.ptr1; - } - if (procPtr == NULL || procPtr->iPtr != (Interp *) interp) { - result = tclLambdaType.setFromAnyProc(interp, objv[2]); - if (result != TCL_OK) { - return result; - } - procPtr = objv[2]->internalRep.twoPtrValue.ptr1; + + procPtr = TclGetLambdaFromObj(interp, objv[2], &nsObjPtr); + if (procPtr == NULL) { + return TCL_ERROR; } memset(&cmd, 0, sizeof(Command)); - nsObjPtr = objv[2]->internalRep.twoPtrValue.ptr2; result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr); if (result != TCL_OK) { return result; diff --git a/generic/tclInt.h b/generic/tclInt.h index e8eba7a..1017fd6 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2944,6 +2944,8 @@ MODULE_SCOPE int TclGetChannelFromObj(Tcl_Interp *interp, int *modePtr, int flags); MODULE_SCOPE int TclGetCompletionCodeFromObj(Tcl_Interp *interp, Tcl_Obj *value, int *code); +MODULE_SCOPE Proc * TclGetLambdaFromObj(Tcl_Interp *interp, + Tcl_Obj *objPtr, Tcl_Obj **nsObjPtrPtr); MODULE_SCOPE int TclGetNumberFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, ClientData *clientDataPtr, int *typePtr); diff --git a/generic/tclProc.c b/generic/tclProc.c index ac65bde..2f0da70 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -15,6 +15,7 @@ #include "tclInt.h" #include "tclCompile.h" +#include /* * Variables that are part of the [apply] command implementation and which @@ -91,13 +92,31 @@ static const Tcl_ObjType levelReferenceType = { * will execute within. IF YOU CHANGE THIS, CHECK IN tclDisassemble.c TOO. */ -const Tcl_ObjType tclLambdaType = { +static const Tcl_ObjType lambdaType = { "lambdaExpr", /* name */ FreeLambdaInternalRep, /* freeIntRepProc */ DupLambdaInternalRep, /* dupIntRepProc */ NULL, /* updateStringProc */ SetLambdaFromAny /* setFromAnyProc */ }; + +#define LambdaSetIntRep(objPtr, procPtr, nsObjPtr) \ + do { \ + Tcl_ObjIntRep ir; \ + ir.twoPtrValue.ptr1 = (procPtr); \ + ir.twoPtrValue.ptr2 = (nsObjPtr); \ + Tcl_IncrRefCount((nsObjPtr)); \ + Tcl_StoreIntRep((objPtr), &lambdaType, &ir); \ + } while (0) + +#define LambdaGetIntRep(objPtr, procPtr, nsObjPtr) \ + do { \ + const Tcl_ObjIntRep *irPtr; \ + irPtr = Tcl_FetchIntRep((objPtr), &lambdaType); \ + (procPtr) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \ + (nsObjPtr) = irPtr ? irPtr->twoPtrValue.ptr2 : NULL; \ + } while (0) + /* *---------------------------------------------------------------------- @@ -2423,15 +2442,15 @@ DupLambdaInternalRep( Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ register Tcl_Obj *copyPtr) /* Object with internal rep to set. */ { - Proc *procPtr = srcPtr->internalRep.twoPtrValue.ptr1; - Tcl_Obj *nsObjPtr = srcPtr->internalRep.twoPtrValue.ptr2; + Proc *procPtr; + Tcl_Obj *nsObjPtr; - copyPtr->internalRep.twoPtrValue.ptr1 = procPtr; - copyPtr->internalRep.twoPtrValue.ptr2 = nsObjPtr; + LambdaGetIntRep(srcPtr, procPtr, nsObjPtr); + assert(procPtr != NULL); procPtr->refCount++; - Tcl_IncrRefCount(nsObjPtr); - copyPtr->typePtr = &tclLambdaType; + + LambdaSetIntRep(copyPtr, procPtr, nsObjPtr); } static void @@ -2439,14 +2458,16 @@ FreeLambdaInternalRep( register Tcl_Obj *objPtr) /* CmdName object with internal representation * to free. */ { - Proc *procPtr = objPtr->internalRep.twoPtrValue.ptr1; - Tcl_Obj *nsObjPtr = objPtr->internalRep.twoPtrValue.ptr2; + Proc *procPtr; + Tcl_Obj *nsObjPtr; + + LambdaGetIntRep(objPtr, procPtr, nsObjPtr); + assert(procPtr != NULL); if (procPtr->refCount-- == 1) { TclProcCleanupProc(procPtr); } TclDecrRefCount(nsObjPtr); - objPtr->typePtr = NULL; } static int @@ -2467,7 +2488,7 @@ SetLambdaFromAny( /* * Convert objPtr to list type first; if it cannot be converted, or if its - * length is not 2, then it cannot be converted to tclLambdaType. + * length is not 2, then it cannot be converted to lambdaType. */ result = TclListObjGetElements(NULL, objPtr, &objc, &objv); @@ -2608,21 +2629,42 @@ SetLambdaFromAny( } } - Tcl_IncrRefCount(nsObjPtr); - /* * Free the list internalrep of objPtr - this will free argsPtr, but * bodyPtr retains a reference from the Proc structure. Then finish the - * conversion to tclLambdaType. + * conversion to lambdaType. */ - TclFreeIntRep(objPtr); - - objPtr->internalRep.twoPtrValue.ptr1 = procPtr; - objPtr->internalRep.twoPtrValue.ptr2 = nsObjPtr; - objPtr->typePtr = &tclLambdaType; + LambdaSetIntRep(objPtr, procPtr, nsObjPtr); return TCL_OK; } + +Proc * +TclGetLambdaFromObj( + Tcl_Interp *interp, + Tcl_Obj *objPtr, + Tcl_Obj **nsObjPtrPtr) +{ + Proc *procPtr; + Tcl_Obj *nsObjPtr; + + LambdaGetIntRep(objPtr, procPtr, nsObjPtr); + + if (procPtr == NULL) { + if (SetLambdaFromAny(interp, objPtr) != TCL_OK) { + return NULL; + } + LambdaGetIntRep(objPtr, procPtr, nsObjPtr); + } + + assert(procPtr != NULL); + if (procPtr->iPtr != (Interp *)interp) { + return NULL; + } + + *nsObjPtrPtr = nsObjPtr; + return procPtr; +} /* *---------------------------------------------------------------------- @@ -2676,10 +2718,9 @@ TclNRApplyObjCmd( */ lambdaPtr = objv[1]; - if (lambdaPtr->typePtr == &tclLambdaType) { - procPtr = lambdaPtr->internalRep.twoPtrValue.ptr1; - } + procPtr = TclGetLambdaFromObj(interp, lambdaPtr, &nsObjPtr); + if (procPtr == NULL) { #define JOE_EXTENSION 0 /* * Note: this code is NOT FUNCTIONAL due to the NR implementation; DO NOT @@ -2688,7 +2729,6 @@ TclNRApplyObjCmd( */ #if JOE_EXTENSION - else { /* * Joe English's suggestion to allow cmdNames to function as lambdas. */ @@ -2701,23 +2741,15 @@ TclNRApplyObjCmd( &elemPtr) == TCL_OK && numElem == 1)) { return Tcl_EvalObjv(interp, objc-1, objv+1, 0); } - } #endif - - if ((procPtr == NULL) || (procPtr->iPtr != iPtr)) { - result = SetLambdaFromAny(interp, lambdaPtr); - if (result != TCL_OK) { - return result; - } - procPtr = lambdaPtr->internalRep.twoPtrValue.ptr1; + return TCL_ERROR; } /* - * Find the namespace where this lambda should run, and push a call frame - * for that namespace. Note that TclObjInterpProc() will pop it. + * Push a call frame for the lambda namespace. + * Note that TclObjInterpProc() will pop it. */ - nsObjPtr = lambdaPtr->internalRep.twoPtrValue.ptr2; result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr); if (result != TCL_OK) { return TCL_ERROR; -- cgit v0.12 From 08b6a144bd140b72f2b4400a39f23eee149542c9 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 5 Apr 2016 00:05:35 +0000 Subject: Revise the "procbody" Tcl_ObjType to use proposed routines. --- generic/tclProc.c | 33 ++++++++++++++++++++++----------- 1 file changed, 22 insertions(+), 11 deletions(-) diff --git a/generic/tclProc.c b/generic/tclProc.c index 2f0da70..a95cad4 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -69,6 +69,22 @@ const Tcl_ObjType tclProcBodyType = { * should panic instead. */ }; +#define ProcSetIntRep(objPtr, procPtr) \ + do { \ + Tcl_ObjIntRep ir; \ + (procPtr)->refCount++; \ + ir.twoPtrValue.ptr1 = (procPtr); \ + ir.twoPtrValue.ptr2 = NULL; \ + Tcl_StoreIntRep((objPtr), &tclProcBodyType, &ir); \ + } while (0) + +#define ProcGetIntRep(objPtr, procPtr) \ + do { \ + const Tcl_ObjIntRep *irPtr; \ + irPtr = Tcl_FetchIntRep((objPtr), &tclProcBodyType); \ + (procPtr) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \ + } while (0) + /* * The [upvar]/[uplevel] level reference type. Uses the twoPtrValue field, * encoding the type of level reference in ptr and the actual parsed out @@ -339,7 +355,7 @@ Tcl_ProcObjCmd( * of all procs whose argument list is just _args_ */ - if (objv[3]->typePtr == &tclProcBodyType) { + if (Tcl_FetchIntRep(objv[3], &tclProcBodyType)) { goto done; } @@ -416,14 +432,15 @@ TclCreateProc( Interp *iPtr = (Interp *) interp; const char **argArray = NULL; - register Proc *procPtr; + register Proc *procPtr = NULL; int i, length, result, numArgs; const char *args, *bytes, *p; register CompiledLocal *localPtr = NULL; Tcl_Obj *defPtr; int precompiled = 0; - if (bodyPtr->typePtr == &tclProcBodyType) { + ProcGetIntRep(bodyPtr, procPtr); + if (procPtr != NULL) { /* * Because the body is a TclProProcBody, the actual body is already * compiled, and it is not shared with anyone else, so it's OK not to @@ -436,7 +453,6 @@ TclCreateProc( * will be holding a reference to it. */ - procPtr = bodyPtr->internalRep.twoPtrValue.ptr1; procPtr->iPtr = iPtr; procPtr->refCount++; precompiled = 1; @@ -2355,10 +2371,7 @@ TclNewProcBodyObj( TclNewObj(objPtr); if (objPtr) { - objPtr->typePtr = &tclProcBodyType; - objPtr->internalRep.twoPtrValue.ptr1 = procPtr; - - procPtr->refCount++; + ProcSetIntRep(objPtr, procPtr); } return objPtr; @@ -2388,9 +2401,7 @@ ProcBodyDup( { Proc *procPtr = srcPtr->internalRep.twoPtrValue.ptr1; - dupPtr->typePtr = &tclProcBodyType; - dupPtr->internalRep.twoPtrValue.ptr1 = procPtr; - procPtr->refCount++; + ProcSetIntRep(dupPtr, procPtr); } /* -- cgit v0.12 From b42de3a4f38cb8f3837142c0107244102e74e113 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 7 Apr 2016 21:07:26 +0000 Subject: Revise "levelReference" ObjType to use proposed routines. --- generic/tclProc.c | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/generic/tclProc.c b/generic/tclProc.c index 570e5ba..6307002 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -841,6 +841,7 @@ TclObjGetFrame( { register Interp *iPtr = (Interp *) interp; int curLevel, level, result; + const Tcl_ObjIntRep *irPtr; const char *name = NULL; /* @@ -861,16 +862,17 @@ TclObjGetFrame( && (level >= 0)) { level = curLevel - level; result = 1; - } else if (objPtr->typePtr == &levelReferenceType) { - level = (int) objPtr->internalRep.longValue; + } else if ((irPtr = Tcl_FetchIntRep(objPtr, &levelReferenceType))) { + level = irPtr->longValue; result = 1; } else { name = TclGetString(objPtr); if (name[0] == '#') { if (TCL_OK == Tcl_GetInt(NULL, name+1, &level) && level >= 0) { - TclFreeIntRep(objPtr); - objPtr->typePtr = &levelReferenceType; - objPtr->internalRep.longValue = level; + Tcl_ObjIntRep ir; + + ir.longValue = level; + Tcl_StoreIntRep(objPtr, &levelReferenceType, &ir); result = 1; } else { result = -1; -- cgit v0.12 From 188ebe6ceb9813b6e988dcb7af19ee3b3fe51f3b Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 7 Apr 2016 21:34:21 +0000 Subject: Revise the "TclOO method name" objType to use proposed routines. --- generic/tclOOCall.c | 29 ++++++++++++++--------------- 1 file changed, 14 insertions(+), 15 deletions(-) diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c index facf90d..68c4b8e 100644 --- a/generic/tclOOCall.c +++ b/generic/tclOOCall.c @@ -15,6 +15,7 @@ #endif #include "tclInt.h" #include "tclOOInt.h" +#include /* * Structure containing a CallContext and any other values needed only during @@ -92,6 +93,7 @@ static const Tcl_ObjType methodNameType = { NULL, NULL }; + /* * ---------------------------------------------------------------------- @@ -181,10 +183,11 @@ StashCallChain( Tcl_Obj *objPtr, CallChain *callPtr) { + Tcl_ObjIntRep ir; + callPtr->refCount++; - TclFreeIntRep(objPtr); - objPtr->typePtr = &methodNameType; - objPtr->internalRep.twoPtrValue.ptr1 = callPtr; + ir.twoPtrValue.ptr1 = callPtr; + Tcl_StoreIntRep(objPtr, &methodNameType, &ir); } void @@ -211,21 +214,16 @@ DupMethodNameRep( Tcl_Obj *srcPtr, Tcl_Obj *dstPtr) { - register CallChain *callPtr = srcPtr->internalRep.twoPtrValue.ptr1; - - dstPtr->typePtr = &methodNameType; - dstPtr->internalRep.twoPtrValue.ptr1 = callPtr; - callPtr->refCount++; + StashCallChain(dstPtr, + Tcl_FetchIntRep(srcPtr, &methodNameType)->twoPtrValue.ptr1); } static void FreeMethodNameRep( Tcl_Obj *objPtr) { - register CallChain *callPtr = objPtr->internalRep.twoPtrValue.ptr1; - - TclOODeleteChain(callPtr); - objPtr->typePtr = NULL; + TclOODeleteChain( + Tcl_FetchIntRep(objPtr, &methodNameType)->twoPtrValue.ptr1); } /* @@ -962,15 +960,16 @@ TclOOGetCallContext( * the object, and in the class). */ + const Tcl_ObjIntRep *irPtr; const int reuseMask = ((flags & PUBLIC_METHOD) ? ~0 : ~PUBLIC_METHOD); - if (cacheInThisObj->typePtr == &methodNameType) { - callPtr = cacheInThisObj->internalRep.twoPtrValue.ptr1; + if ((irPtr = Tcl_FetchIntRep(cacheInThisObj, &methodNameType))) { + callPtr = irPtr->twoPtrValue.ptr1; if (IsStillValid(callPtr, oPtr, flags, reuseMask)) { callPtr->refCount++; goto returnContext; } - FreeMethodNameRep(cacheInThisObj); + Tcl_FreeIntRep(cacheInThisObj); } if (oPtr->flags & USE_CLASS_CACHE) { -- cgit v0.12 From 2c83a6f53e4a4f245befff0309fc99f77925bfb6 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 11 Apr 2016 01:07:31 +0000 Subject: Revise the "end-offset" objType to use proposed routines, and not export or provide unneeded things. --- generic/tclInt.h | 1 - generic/tclObj.c | 1 - generic/tclUtil.c | 157 ++++++++++++------------------------------------------ tests/obj.test | 48 ----------------- 4 files changed, 34 insertions(+), 173 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index 59fa018..1aea09b 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2685,7 +2685,6 @@ MODULE_SCOPE const Tcl_ObjType tclBooleanType; MODULE_SCOPE const Tcl_ObjType tclByteArrayType; MODULE_SCOPE const Tcl_ObjType tclByteCodeType; MODULE_SCOPE const Tcl_ObjType tclDoubleType; -MODULE_SCOPE const Tcl_ObjType tclEndOffsetType; MODULE_SCOPE const Tcl_ObjType tclIntType; MODULE_SCOPE const Tcl_ObjType tclListType; MODULE_SCOPE const Tcl_ObjType tclDictType; diff --git a/generic/tclObj.c b/generic/tclObj.c index 338e027..4ec2779 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -397,7 +397,6 @@ TclInitObjSubsystem(void) Tcl_RegisterObjType(&tclByteArrayType); Tcl_RegisterObjType(&tclDoubleType); - Tcl_RegisterObjType(&tclEndOffsetType); Tcl_RegisterObjType(&tclIntType); Tcl_RegisterObjType(&tclStringType); Tcl_RegisterObjType(&tclListType); diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 01f8225..08fc735 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -108,9 +108,8 @@ static void ClearHash(Tcl_HashTable *tablePtr); static void FreeProcessGlobalValue(ClientData clientData); static void FreeThreadHash(ClientData clientData); static Tcl_HashTable * GetThreadHash(Tcl_ThreadDataKey *keyPtr); -static int SetEndOffsetFromAny(Tcl_Interp *interp, - Tcl_Obj *objPtr); -static void UpdateStringOfEndOffset(Tcl_Obj *objPtr); +static int GetEndOffsetFromObj(Tcl_Obj *objPtr, int endValue, + int *indexPtr); static int FindElement(Tcl_Interp *interp, const char *string, int stringLength, const char *typeStr, const char *typeCode, const char **elementPtr, @@ -123,12 +122,12 @@ static int FindElement(Tcl_Interp *interp, const char *string, * integer, so no memory management is required for it. */ -const Tcl_ObjType tclEndOffsetType = { +static const Tcl_ObjType endOffsetType = { "end-offset", /* name */ NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ - UpdateStringOfEndOffset, /* updateStringProc */ - SetEndOffsetFromAny + NULL, /* updateStringProc */ + NULL }; /* @@ -3560,13 +3559,7 @@ TclGetIntForIndex( return TCL_OK; } - if (SetEndOffsetFromAny(NULL, objPtr) == TCL_OK) { - /* - * If the object is already an offset from the end of the list, or can - * be converted to one, use it. - */ - - *indexPtr = endValue + objPtr->internalRep.longValue; + if (GetEndOffsetFromObj(objPtr, endValue, indexPtr) == TCL_OK) { return TCL_OK; } @@ -3632,135 +3625,53 @@ TclGetIntForIndex( /* *---------------------------------------------------------------------- * - * UpdateStringOfEndOffset -- - * - * Update the string rep of a Tcl object holding an "end-offset" - * expression. - * - * Results: - * None. - * - * Side effects: - * Stores a valid string in the object's string rep. - * - * This function does NOT free any earlier string rep. If it is called on an - * object that already has a valid string rep, it will leak memory. - * - *---------------------------------------------------------------------- - */ - -static void -UpdateStringOfEndOffset( - register Tcl_Obj *objPtr) -{ - char *dst = Tcl_InitStringRep(objPtr, NULL, TCL_INTEGER_SPACE + 5); - int len = 3; - - TclOOM(dst, TCL_INTEGER_SPACE + 6); - - memcpy(dst, "end", len); - if (objPtr->internalRep.longValue != 0) { - dst[len++] = '-'; - len += TclFormatInt(dst+len, -(objPtr->internalRep.longValue)); - } - - (void) Tcl_InitStringRep(objPtr, NULL, len); -} - -/* - *---------------------------------------------------------------------- - * - * SetEndOffsetFromAny -- + * GetEndOffsetFromObj -- * * Look for a string of the form "end[+-]offset" and convert it to an * internal representation holding the offset. * * Results: - * Returns TCL_OK if ok, TCL_ERROR if the string was badly formed. + * Tcl return code. * * Side effects: - * If interp is not NULL, stores an error message in the interpreter - * result. + * May store a Tcl_ObjType. * *---------------------------------------------------------------------- */ static int -SetEndOffsetFromAny( - Tcl_Interp *interp, /* Tcl interpreter or NULL */ - Tcl_Obj *objPtr) /* Pointer to the object to parse */ +GetEndOffsetFromObj( + Tcl_Obj *objPtr, /* Pointer to the object to parse */ + int endValue, /* The value to be stored at "indexPtr" if + * "objPtr" holds "end". */ + int *indexPtr) /* Location filled in with an integer + * representing an index. */ { - int offset; /* Offset in the "end-offset" expression */ - register const char *bytes; /* String rep of the object */ - int length; /* Length of the object's string rep */ + const Tcl_ObjIntRep *irPtr; - /* - * If it's already the right type, we're fine. - */ + while (NULL == (irPtr = Tcl_FetchIntRep(objPtr, &endOffsetType))) { + Tcl_ObjIntRep ir; + int length, offset = 0; + const char *bytes = TclGetStringFromObj(objPtr, &length); - if (objPtr->typePtr == &tclEndOffsetType) { - return TCL_OK; - } - - /* - * Check for a string rep of the right form. - */ - - bytes = TclGetStringFromObj(objPtr, &length); - if ((*bytes != 'e') || (strncmp(bytes, "end", - (size_t)((length > 3) ? 3 : length)) != 0)) { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad index \"%s\": must be end?[+-]integer?", bytes)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", NULL); - } - return TCL_ERROR; - } - - /* - * Convert the string rep. - */ - - if (length <= 3) { - offset = 0; - } else if ((length > 4) && ((bytes[3] == '-') || (bytes[3] == '+'))) { - /* - * This is our limited string expression evaluator. Pass everything - * after "end-" to Tcl_GetInt, then reverse for offset. - */ - - if (TclIsSpaceProc(bytes[4])) { - goto badIndexFormat; - } - if (Tcl_GetInt(interp, bytes+4, &offset) != TCL_OK) { + if ((length == 4) || (*bytes != 'e') || (strncmp(bytes, "end", + (size_t)((length > 3) ? 3 : length)) != 0)) { return TCL_ERROR; } - if (bytes[3] == '-') { - offset = -offset; - } - } else { - /* - * Conversion failed. Report the error. - */ - - badIndexFormat: - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad index \"%s\": must be end?[+-]integer?", bytes)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", NULL); + if (length > 4) { + if (((bytes[3] != '-') && (bytes[3] != '+')) + || (TclIsSpaceProc(bytes[4])) + || (TCL_OK != Tcl_GetInt(NULL, bytes+4, &offset))) { + return TCL_ERROR; + } + if (bytes[3] == '-') { + offset = -offset; + } } - return TCL_ERROR; + ir.longValue = offset; + Tcl_StoreIntRep(objPtr, &endOffsetType, &ir); } - - /* - * The conversion succeeded. Free the old internal rep and set the new - * one. - */ - - TclFreeIntRep(objPtr); - objPtr->internalRep.longValue = offset; - objPtr->typePtr = &tclEndOffsetType; - + *indexPtr = endValue + irPtr->longValue; return TCL_OK; } diff --git a/tests/obj.test b/tests/obj.test index 7bf00f7..8f783fe 100644 --- a/tests/obj.test +++ b/tests/obj.test @@ -31,7 +31,6 @@ test obj-1.1 {Tcl_AppendAllObjTypes, and InitTypeTable, Tcl_RegisterObjType} tes bytecode cmdName dict - end-offset regexp string } { @@ -53,15 +52,6 @@ test obj-2.2 {Tcl_GetObjType and Tcl_ConvertToType} testobj { lappend result [testobj refcount 1] } {{} 12 12 bytearray 3} -test obj-3.1 {Tcl_ConvertToType error} testobj { - list [testdoubleobj set 1 12.34] \ - [catch {testobj convert 1 end-offset} msg] \ - $msg -} {12.34 1 {bad index "12.34": must be end?[+-]integer?}} -test obj-3.2 {Tcl_ConvertToType error, "empty string" object} testobj { - list [testobj newobj 1] [catch {testobj convert 1 end-offset} msg] $msg -} {{} 1 {bad index "": must be end?[+-]integer?}} - test obj-4.1 {Tcl_NewObj and AllocateFreeObjects} testobj { set result "" lappend result [testobj freeallvars] @@ -551,44 +541,6 @@ test obj-30.1 {Ref counting and object deletion, simple types} testobj { lappend result [testobj refcount 2] } {{} 1024 1024 int 4 4 0 int 3 2} - -test obj-31.1 {regenerate string rep of "end"} testobj { - testobj freeallvars - teststringobj set 1 end - testobj convert 1 end-offset - testobj invalidateStringRep 1 -} end -test obj-31.2 {regenerate string rep of "end-1"} testobj { - testobj freeallvars - teststringobj set 1 end-0x1 - testobj convert 1 end-offset - testobj invalidateStringRep 1 -} end-1 -test obj-31.3 {regenerate string rep of "end--1"} testobj { - testobj freeallvars - teststringobj set 1 end--0x1 - testobj convert 1 end-offset - testobj invalidateStringRep 1 -} end--1 -test obj-31.4 {regenerate string rep of "end-bigInteger"} testobj { - testobj freeallvars - teststringobj set 1 end-0x7fffffff - testobj convert 1 end-offset - testobj invalidateStringRep 1 -} end-2147483647 -test obj-31.5 {regenerate string rep of "end--bigInteger"} testobj { - testobj freeallvars - teststringobj set 1 end--0x7fffffff - testobj convert 1 end-offset - testobj invalidateStringRep 1 -} end--2147483647 -test obj-31.6 {regenerate string rep of "end--bigInteger"} {testobj longIs32bit} { - testobj freeallvars - teststringobj set 1 end--0x80000000 - testobj convert 1 end-offset - testobj invalidateStringRep 1 -} end--2147483648 - test obj-32.1 {freeing very large object trees} { set x {} for {set i 0} {$i<100000} {incr i} { -- cgit v0.12 From 53c50e58bf25cab1fe612b66471ad13a0f3b6cf4 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 11 Apr 2016 17:46:20 +0000 Subject: Use static name for a static struct. --- generic/tclPathObj.c | 38 +++++++++++++++++++------------------- 1 file changed, 19 insertions(+), 19 deletions(-) diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index 99d576d..90a5ebe 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -35,7 +35,7 @@ static int MakePathFromNormalized(Tcl_Interp *interp, * internally. */ -static const Tcl_ObjType tclFsPathType = { +static const Tcl_ObjType fsPathType = { "path", /* name */ FreeFsPathInternalRep, /* freeIntRepProc */ DupFsPathInternalRep, /* dupIntRepProc */ @@ -563,7 +563,7 @@ TclPathPart( Tcl_Obj *pathPtr, /* Path to take dirname of */ Tcl_PathPart portion) /* Requested portion of name */ { - if (pathPtr->typePtr == &tclFsPathType) { + if (pathPtr->typePtr == &fsPathType) { FsPath *fsPathPtr = PATHOBJ(pathPtr); if (PATHFLAGS(pathPtr) != 0) { @@ -872,7 +872,7 @@ TclJoinPath( */ if ((i == (elements-2)) && (i == 0) - && (elt->typePtr == &tclFsPathType) + && (elt->typePtr == &fsPathType) && !((elt->bytes != NULL) && (elt->bytes[0] == '\0'))) { Tcl_Obj *tailObj = objv[i+1]; @@ -1145,7 +1145,7 @@ Tcl_FSConvertToPathType( * path. */ - if (pathPtr->typePtr == &tclFsPathType) { + if (pathPtr->typePtr == &fsPathType) { if (TclFSEpochOk(PATHOBJ(pathPtr)->filesystemEpoch)) { return TCL_OK; } @@ -1172,7 +1172,7 @@ Tcl_FSConvertToPathType( * UpdateStringOfFsPath(pathPtr); * } * FreeFsPathInternalRep(pathPtr); - * return Tcl_ConvertToType(interp, pathPtr, &tclFsPathType); + * return Tcl_ConvertToType(interp, pathPtr, &fsPathType); * } * } * @@ -1309,7 +1309,7 @@ TclNewFSPathObj( SETPATHOBJ(pathPtr, fsPathPtr); PATHFLAGS(pathPtr) = TCLPATH_APPENDED; - pathPtr->typePtr = &tclFsPathType; + pathPtr->typePtr = &fsPathType; pathPtr->bytes = NULL; pathPtr->length = 0; @@ -1412,7 +1412,7 @@ TclFSMakePathRelative( int cwdLen, len; const char *tempStr; - if (pathPtr->typePtr == &tclFsPathType) { + if (pathPtr->typePtr == &fsPathType) { FsPath *fsPathPtr = PATHOBJ(pathPtr); if (PATHFLAGS(pathPtr) != 0 && fsPathPtr->cwdPtr == cwdPtr) { @@ -1480,7 +1480,7 @@ MakePathFromNormalized( { FsPath *fsPathPtr; - if (pathPtr->typePtr == &tclFsPathType) { + if (pathPtr->typePtr == &fsPathType) { return TCL_OK; } @@ -1525,7 +1525,7 @@ MakePathFromNormalized( SETPATHOBJ(pathPtr, fsPathPtr); PATHFLAGS(pathPtr) = 0; - pathPtr->typePtr = &tclFsPathType; + pathPtr->typePtr = &fsPathType; return TCL_OK; } @@ -1602,7 +1602,7 @@ Tcl_FSNewNativePath( SETPATHOBJ(pathPtr, fsPathPtr); PATHFLAGS(pathPtr) = 0; - pathPtr->typePtr = &tclFsPathType; + pathPtr->typePtr = &fsPathType; return pathPtr; } @@ -1656,7 +1656,7 @@ Tcl_FSGetTranslatedPath( retObj = Tcl_FSJoinToPath(translatedCwdPtr, 1, &srcFsPathPtr->normPathPtr); srcFsPathPtr->translatedPathPtr = retObj; - if (translatedCwdPtr->typePtr == &tclFsPathType) { + if (translatedCwdPtr->typePtr == &fsPathType) { srcFsPathPtr->filesystemEpoch = PATHOBJ(translatedCwdPtr)->filesystemEpoch; } else { @@ -1827,7 +1827,7 @@ Tcl_FSGetNormalizedPath( /* * NOTE: here we are (dangerously?) assuming that origDir points - * to a Tcl_Obj with Tcl_ObjType == &tclFsPathType. The + * to a Tcl_Obj with Tcl_ObjType == &fsPathType. The * pathType = Tcl_FSGetPathType(fsPathPtr->cwdPtr); * above that set the pathType value should have established that, * but it's far less clear on what basis we know there's been no @@ -2152,7 +2152,7 @@ TclFSEnsureEpochOk( { FsPath *srcFsPathPtr; - if (pathPtr->typePtr != &tclFsPathType) { + if (pathPtr->typePtr != &fsPathType) { return TCL_OK; } @@ -2216,7 +2216,7 @@ TclFSSetPathDetails( * Make sure pathPtr is of the correct type. */ - if (pathPtr->typePtr != &tclFsPathType) { + if (pathPtr->typePtr != &fsPathType) { if (SetFsPathFromAny(NULL, pathPtr) != TCL_OK) { return; } @@ -2315,7 +2315,7 @@ SetFsPathFromAny( Tcl_Obj *transPtr; char *name; - if (pathPtr->typePtr == &tclFsPathType) { + if (pathPtr->typePtr == &fsPathType) { return TCL_OK; } @@ -2477,7 +2477,7 @@ SetFsPathFromAny( TclFreeIntRep(pathPtr); SETPATHOBJ(pathPtr, fsPathPtr); PATHFLAGS(pathPtr) = 0; - pathPtr->typePtr = &tclFsPathType; + pathPtr->typePtr = &fsPathType; return TCL_OK; } @@ -2569,7 +2569,7 @@ DupFsPathInternalRep( copyFsPathPtr->fsPtr = srcFsPathPtr->fsPtr; copyFsPathPtr->filesystemEpoch = srcFsPathPtr->filesystemEpoch; - copyPtr->typePtr = &tclFsPathType; + copyPtr->typePtr = &fsPathType; } /* @@ -2642,7 +2642,7 @@ TclNativePathInFilesystem( * semantics of Tcl (at present anyway), so we have to abide by them here. */ - if (pathPtr->typePtr == &tclFsPathType) { + if (pathPtr->typePtr == &fsPathType) { if (pathPtr->bytes != NULL && pathPtr->bytes[0] == '\0') { /* * We reject the empty path "". @@ -2657,7 +2657,7 @@ TclNativePathInFilesystem( } else { /* * It is somewhat unusual to reach this code path without the object - * being of tclFsPathType. However, we do our best to deal with the + * being of fsPathType. However, we do our best to deal with the * situation. */ -- cgit v0.12 From 712675a74471cd7bac4f09430c1df7e6a1585e9a Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 20 Apr 2016 18:02:45 +0000 Subject: Revise "dictIterator" objType to use proposed routines. --- generic/tclExecute.c | 37 ++++++++++++++++++++++++------------- 1 file changed, 24 insertions(+), 13 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 5fcde79..831ef6f 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -823,20 +823,22 @@ ReleaseDictIterator( { Tcl_DictSearch *searchPtr; Tcl_Obj *dictPtr; + const Tcl_ObjIntRep *irPtr; + + irPtr = Tcl_FetchIntRep(objPtr, &dictIteratorType); + assert(irPtr != NULL); /* * First kill the search, and then release the reference to the dictionary * that we were holding. */ - searchPtr = objPtr->internalRep.twoPtrValue.ptr1; + searchPtr = irPtr->twoPtrValue.ptr1; Tcl_DictObjDone(searchPtr); ckfree(searchPtr); - dictPtr = objPtr->internalRep.twoPtrValue.ptr2; + dictPtr = irPtr->twoPtrValue.ptr2; TclDecrRefCount(dictPtr); - - objPtr->typePtr = NULL; } /* @@ -7647,13 +7649,16 @@ TEBCresume( TRACE_ERROR(interp); goto gotError; } - TclNewObj(statePtr); - statePtr->typePtr = &dictIteratorType; - statePtr->internalRep.twoPtrValue.ptr1 = searchPtr; - statePtr->internalRep.twoPtrValue.ptr2 = dictPtr; + { + Tcl_ObjIntRep ir; + TclNewObj(statePtr); + ir.twoPtrValue.ptr1 = searchPtr; + ir.twoPtrValue.ptr2 = dictPtr; + Tcl_StoreIntRep(statePtr, &dictIteratorType, &ir); + } varPtr = LOCAL(opnd); if (varPtr->value.objPtr) { - if (varPtr->value.objPtr->typePtr == &dictIteratorType) { + if (Tcl_FetchIntRep(varPtr->value.objPtr, &dictIteratorType)) { Tcl_Panic("mis-issued dictFirst!"); } TclDecrRefCount(varPtr->value.objPtr); @@ -7666,11 +7671,17 @@ TEBCresume( opnd = TclGetUInt4AtPtr(pc+1); TRACE(("%u => ", opnd)); statePtr = (*LOCAL(opnd)).value.objPtr; - if (statePtr == NULL || statePtr->typePtr != &dictIteratorType) { - Tcl_Panic("mis-issued dictNext!"); + { + const Tcl_ObjIntRep *irPtr; + + if (statePtr && + (irPtr = Tcl_FetchIntRep(statePtr, &dictIteratorType))) { + searchPtr = irPtr->twoPtrValue.ptr1; + Tcl_DictObjNext(searchPtr, &keyPtr, &valuePtr, &done); + } else { + Tcl_Panic("mis-issued dictNext!"); + } } - searchPtr = statePtr->internalRep.twoPtrValue.ptr1; - Tcl_DictObjNext(searchPtr, &keyPtr, &valuePtr, &done); pushDictIteratorResult: if (done) { TclNewObj(emptyPtr); -- cgit v0.12 From 8819aab738e9e53aecbc69f4c3ce8c932241d387 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 22 Apr 2016 18:57:38 +0000 Subject: repair merge --- generic/tclAssembly.c | 3 ++- generic/tclCompile.h | 7 +++++++ 2 files changed, 9 insertions(+), 1 deletion(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 3928956..9ea0b48 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -32,6 +32,7 @@ #include "tclInt.h" #include "tclCompile.h" #include "tclOOInt.h" +#include /* * Structure that represents a range of instructions in the bytecode. @@ -4311,7 +4312,7 @@ static void FreeAssembleCodeInternalRep( Tcl_Obj *objPtr) { - ByteCode *codePtr = NULL; + ByteCode *codePtr; ByteCodeGetIntRep(objPtr, &assembleCodeType, codePtr); assert(codePtr != NULL); diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 86a9db0..f046091 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -514,6 +514,13 @@ typedef struct ByteCode { * created. */ #endif /* TCL_COMPILE_STATS */ } ByteCode; + +#define ByteCodeGetIntRep(objPtr, typePtr, codePtr) \ + do { \ + const Tcl_ObjIntRep *irPtr; \ + irPtr = Tcl_FetchIntRep((objPtr), (typePtr)); \ + (codePtr) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \ + } while (0) /* * Opcodes for the Tcl bytecode instructions. These must correspond to the -- cgit v0.12 From be804ed5e6133fd5a00a433f2c88c13dada0a8ee Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 29 Apr 2016 20:04:12 +0000 Subject: Revise "assemblecode" Tcl_ObjType to proposed routines. --- generic/tclAssembly.c | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 1826fec..b07333a 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -845,15 +845,15 @@ CompileAssembleObj( const char* source; /* String representation of the source code */ int sourceLen; /* Length of the source code in bytes */ - /* * Get the expression ByteCode from the object. If it exists, make sure it * is valid in the current context. */ - if (objPtr->typePtr == &assembleCodeType) { + ByteCodeGetIntRep(objPtr, &assembleCodeType, codePtr); + + if (codePtr) { namespacePtr = iPtr->varFramePtr->nsPtr; - codePtr = objPtr->internalRep.twoPtrValue.ptr1; if (((Interp *) *codePtr->interpHandle == iPtr) && (codePtr->compileEpoch == iPtr->compileEpoch) && (codePtr->nsPtr == namespacePtr) -- cgit v0.12 From 2e23e829d9cd7ea52665d333482cedf5255464e5 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 29 Apr 2016 20:20:33 +0000 Subject: Revise the "exprcode" Tcl_ObjType to proposed routines. --- generic/tclExecute.c | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 23337f4..9d8dd25 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -1527,19 +1527,23 @@ CompileExprObj( * Get the expression ByteCode from the object. If it exists, make sure it * is valid in the current context. */ - if (objPtr->typePtr == &exprCodeType) { + + ByteCodeGetIntRep(objPtr, &exprCodeType, codePtr); + + if (codePtr != NULL) { Namespace *namespacePtr = iPtr->varFramePtr->nsPtr; - codePtr = objPtr->internalRep.twoPtrValue.ptr1; if (((Interp *) *codePtr->interpHandle != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch) || (codePtr->nsPtr != namespacePtr) || (codePtr->nsEpoch != namespacePtr->resolverEpoch) || (codePtr->localCachePtr != iPtr->varFramePtr->localCachePtr)) { TclFreeIntRep(objPtr); + codePtr = NULL; } } - if (objPtr->typePtr != &exprCodeType) { + + if (codePtr == NULL) { /* * TIP #280: No invoker (yet) - Expression compilation. */ -- cgit v0.12 From c22277cf6a24458c9ffd0fdbbf4aaa7229725a0b Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 29 Apr 2016 20:33:43 +0000 Subject: more revisions --- generic/tclCompile.c | 23 ++++++++++++++--------- generic/tclCompile.h | 10 ++++++++++ 2 files changed, 24 insertions(+), 9 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 96b418c..9485d98 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -967,7 +967,10 @@ static void FreeByteCodeInternalRep( register Tcl_Obj *objPtr) /* Object whose internal rep to free. */ { - register ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1; + ByteCode *codePtr; + + ByteCodeGetIntRep(objPtr, &tclByteCodeType, codePtr); + assert(codePtr != NULL); TclReleaseByteCode(codePtr); } @@ -1297,10 +1300,11 @@ CompileSubstObj( Interp *iPtr = (Interp *) interp; ByteCode *codePtr = NULL; - if (objPtr->typePtr == &substCodeType) { + ByteCodeGetIntRep(objPtr, &subsCodeType, codePtr); + + if (codePtr != NULL) { Namespace *nsPtr = iPtr->varFramePtr->nsPtr; - codePtr = objPtr->internalRep.twoPtrValue.ptr1; if (flags != PTR2INT(objPtr->internalRep.twoPtrValue.ptr2) || ((Interp *) *codePtr->interpHandle != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch) @@ -1309,9 +1313,10 @@ CompileSubstObj( || (codePtr->localCachePtr != iPtr->varFramePtr->localCachePtr)) { TclFreeIntRep(objPtr); + codePtr = NULL; } } - if (objPtr->typePtr != &substCodeType) { + if (codePtr == NULL) { CompileEnv compEnv; int numBytes; const char *bytes = Tcl_GetStringFromObj(objPtr, &numBytes); @@ -1325,7 +1330,6 @@ CompileSubstObj( codePtr = TclInitByteCodeObj(objPtr, &substCodeType, &compEnv); TclFreeCompileEnv(&compEnv); - objPtr->internalRep.twoPtrValue.ptr1 = codePtr; objPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(flags); if (iPtr->varFramePtr->localCachePtr) { codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr; @@ -1365,7 +1369,10 @@ static void FreeSubstCodeInternalRep( register Tcl_Obj *objPtr) /* Object whose internal rep to free. */ { - register ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1; + register ByteCode *codePtr; + + ByteCodeGetIntRep(objPtr, &substCodeType, codePtr); + assert(codePtr != NULL); TclReleaseByteCode(codePtr); } @@ -2897,9 +2904,7 @@ TclInitByteCodeObj( * by making its internal rep point to the just compiled ByteCode. */ - TclFreeIntRep(objPtr); - objPtr->internalRep.twoPtrValue.ptr1 = codePtr; - objPtr->typePtr = typePtr; + ByteCodeSetIntRep(objPtr, typePtr, codePtr); return codePtr; } diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 502dcf8..2f7a180 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -515,6 +515,16 @@ typedef struct ByteCode { #endif /* TCL_COMPILE_STATS */ } ByteCode; +#define ByteCodeSetIntRep(objPtr, typePtr, codePtr) \ + do { \ + Tcl_ObjIntRep ir; \ + ir.twoPtrValue.ptr1 = (codePtr); \ + ir.twoPtrValue.ptr2 = NULL; \ + Tcl_StoreIntRep((objPtr), (typePtr), &ir); \ + } while (0) + + + #define ByteCodeGetIntRep(objPtr, typePtr, codePtr) \ do { \ const Tcl_ObjIntRep *irPtr; \ -- cgit v0.12 From 9f2bd1e80f785a0de4aa8065bb5735acc4fb3da6 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 29 Apr 2016 20:34:29 +0000 Subject: typo --- generic/tclCompile.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 9485d98..8c2d703 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1300,7 +1300,7 @@ CompileSubstObj( Interp *iPtr = (Interp *) interp; ByteCode *codePtr = NULL; - ByteCodeGetIntRep(objPtr, &subsCodeType, codePtr); + ByteCodeGetIntRep(objPtr, &substCodeType, codePtr); if (codePtr != NULL) { Namespace *nsPtr = iPtr->varFramePtr->nsPtr; -- cgit v0.12 From 0d83fc1704c2c77276583d12c60a0c95dcf5c285 Mon Sep 17 00:00:00 2001 From: dgp Date: Sat, 30 Apr 2016 17:47:40 +0000 Subject: More ByteCode revisions. --- generic/tclDisassemble.c | 30 +++++++++++++++++------------- generic/tclExecute.c | 12 +++++++----- generic/tclProc.c | 34 ++++++++++++++++++++++------------ 3 files changed, 46 insertions(+), 30 deletions(-) diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index 83e950a..ad4af5c 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -62,12 +62,6 @@ static const Tcl_ObjType instNameType = { (inst) = irPtr->longValue; \ } while (0) -/* - * How to get the bytecode out of a Tcl_Obj. - */ - -#define BYTECODE(objPtr) \ - ((ByteCode *) (objPtr)->internalRep.twoPtrValue.ptr1) /* *---------------------------------------------------------------------- @@ -262,15 +256,19 @@ DisassembleByteCodeObj( Tcl_Interp *interp, Tcl_Obj *objPtr) /* The bytecode object to disassemble. */ { - ByteCode *codePtr = BYTECODE(objPtr); + ByteCode *codePtr; unsigned char *codeStart, *codeLimit, *pc; unsigned char *codeDeltaNext, *codeLengthNext; unsigned char *srcDeltaNext, *srcLengthNext; int codeOffset, codeLen, srcOffset, srcLen, numCmds, delta, i, line; - Interp *iPtr = (Interp *) *codePtr->interpHandle; + Interp *iPtr; Tcl_Obj *bufferObj, *fileObj; char ptrBuf1[20], ptrBuf2[20]; + ByteCodeGetIntRep(objPtr, &tclByteCodeType, codePtr); + + iPtr = (Interp *) *codePtr->interpHandle; + TclNewObj(bufferObj); if (codePtr->refCount <= 0) { return bufferObj; /* Already freed. */ @@ -966,13 +964,15 @@ DisassembleByteCodeAsDicts( * procedure, if one exists. */ Tcl_Obj *objPtr) /* The bytecode-holding value to take apart */ { - ByteCode *codePtr = BYTECODE(objPtr); + ByteCode *codePtr; Tcl_Obj *description, *literals, *variables, *instructions, *inst; Tcl_Obj *aux, *exn, *commands, *file; unsigned char *pc, *opnd, *codeOffPtr, *codeLenPtr, *srcOffPtr, *srcLenPtr; int codeOffset, codeLength, sourceOffset, sourceLength; int i, val, line; + ByteCodeGetIntRep(objPtr, &tclByteCodeType, codePtr); + /* * Get the literals from the bytecode. */ @@ -1308,6 +1308,7 @@ Tcl_DisassembleObjCmd( Proc *procPtr = NULL; Tcl_HashEntry *hPtr; Object *oPtr; + ByteCode *codePtr; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "type ..."); @@ -1387,8 +1388,9 @@ Tcl_DisassembleObjCmd( Tcl_WrongNumArgs(interp, 2, objv, "script"); return TCL_ERROR; } - if ((objv[2]->typePtr != &tclByteCodeType) - && (TclSetByteCodeFromAny(interp, objv[2], NULL, NULL) != TCL_OK)) { + + if ((NULL == Tcl_FetchIntRep(objv[2], &tclByteCodeType)) && (TCL_OK + != TclSetByteCodeFromAny(interp, objv[2], NULL, NULL))) { return TCL_ERROR; } codeObjPtr = objv[2]; @@ -1458,7 +1460,7 @@ Tcl_DisassembleObjCmd( "METHODTYPE", NULL); return TCL_ERROR; } - if (procPtr->bodyPtr->typePtr != &tclByteCodeType) { + if (NULL == Tcl_FetchIntRep(procPtr->bodyPtr, &tclByteCodeType)) { Command cmd; /* @@ -1486,7 +1488,9 @@ Tcl_DisassembleObjCmd( * Do the actual disassembly. */ - if (BYTECODE(codeObjPtr)->flags & TCL_BYTECODE_PRECOMPILED) { + ByteCodeGetIntRep(codeObjPtr, &tclByteCodeType, codePtr); + + if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "may not disassemble prebuilt bytecode", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 9d8dd25..1afe259 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -1644,7 +1644,9 @@ static void FreeExprCodeInternalRep( Tcl_Obj *objPtr) { - ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1; + ByteCode *codePtr; + ByteCodeGetIntRep(objPtr, &exprCodeType, codePtr); + assert(codePtr != NULL); TclReleaseByteCode(codePtr); } @@ -1682,7 +1684,8 @@ TclCompileObj( * compilation). Otherwise, check that it is "fresh" enough. */ - if (objPtr->typePtr == &tclByteCodeType) { + ByteCodeGetIntRep(objPtr, &tclByteCodeType, codePtr); + if (codePtr != NULL) { /* * Make sure the Bytecode hasn't been invalidated by, e.g., someone * redefining a command with a compile procedure (this might make the @@ -1700,7 +1703,6 @@ TclCompileObj( * here. */ - codePtr = objPtr->internalRep.twoPtrValue.ptr1; if (((Interp *) *codePtr->interpHandle != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch) || (codePtr->nsPtr != namespacePtr) @@ -1828,7 +1830,7 @@ TclCompileObj( iPtr->invokeWord = word; TclSetByteCodeFromAny(interp, objPtr, NULL, NULL); iPtr->invokeCmdFramePtr = NULL; - codePtr = objPtr->internalRep.twoPtrValue.ptr1; + ByteCodeGetIntRep(objPtr, &tclByteCodeType, codePtr); if (iPtr->varFramePtr->localCachePtr) { codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr; codePtr->localCachePtr->refCount++; @@ -10464,7 +10466,7 @@ EvalStatsCmd( for (i = 0; i < globalTablePtr->numBuckets; i++) { for (entryPtr = globalTablePtr->buckets[i]; entryPtr != NULL; entryPtr = entryPtr->nextPtr) { - if (entryPtr->objPtr->typePtr == &tclByteCodeType) { + if (NULL != Tcl_FetchIntRep(entryPtr->objPtr, &tclByteCodeType)) { numByteCodeLits++; } (void) Tcl_GetStringFromObj(entryPtr->objPtr, &length); diff --git a/generic/tclProc.c b/generic/tclProc.c index 6307002..ef7ce13 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -1196,10 +1196,10 @@ TclInitCompiledLocals( ByteCode *codePtr; bodyPtr = framePtr->procPtr->bodyPtr; - if (bodyPtr->typePtr != &tclByteCodeType) { + ByteCodeGetIntRep(bodyPtr, &tclByteCodeType, codePtr); + if (codePtr == NULL) { Tcl_Panic("body object for proc attached to frame is not a byte code type"); } - codePtr = bodyPtr->internalRep.twoPtrValue.ptr1; if (framePtr->numCompiledLocals) { if (!codePtr->localCachePtr) { @@ -1362,7 +1362,7 @@ InitLocalCache( Proc *procPtr) { Interp *iPtr = procPtr->iPtr; - ByteCode *codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1; + ByteCode *codePtr; int localCt = procPtr->numCompiledLocals; int numArgs = procPtr->numArgs, i = 0; @@ -1372,6 +1372,8 @@ InitLocalCache( CompiledLocal *localPtr; int new; + ByteCodeGetIntRep(procPtr->bodyPtr, &tclByteCodeType, codePtr); + /* * Cache the names and initial values of local variables; store the * cache in both the framePtr for this execution and in the codePtr @@ -1439,11 +1441,13 @@ InitArgsAndLocals( { CallFrame *framePtr = ((Interp *)interp)->varFramePtr; register Proc *procPtr = framePtr->procPtr; - ByteCode *codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1; + ByteCode *codePtr; register Var *varPtr, *defPtr; int localCt = procPtr->numCompiledLocals, numArgs, argCt, i, imax; Tcl_Obj *const *argObjs; + ByteCodeGetIntRep(procPtr->bodyPtr, &tclByteCodeType, codePtr); + /* * Make sure that the local cache of variable names and initial values has * been initialised properly . @@ -1614,7 +1618,8 @@ TclPushProcCallFrame( * local variables are found while compiling. */ - if (procPtr->bodyPtr->typePtr == &tclByteCodeType) { + ByteCodeGetIntRep(procPtr->bodyPtr, &tclByteCodeType, codePtr); + if (codePtr != NULL) { Interp *iPtr = (Interp *) interp; /* @@ -1626,7 +1631,6 @@ TclPushProcCallFrame( * commands and/or resolver changes are considered). */ - codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1; if (((Interp *) *codePtr->interpHandle != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch) || (codePtr->nsPtr != nsPtr) @@ -1824,7 +1828,7 @@ TclNRInterpProcCore( */ procPtr->refCount++; - codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1; + ByteCodeGetIntRep(procPtr->bodyPtr, &tclByteCodeType, codePtr); TclNRAddCallback(interp, InterpProcNR2, procNameObj, errorProc, NULL, NULL); @@ -1958,7 +1962,9 @@ TclProcCompileProc( { Interp *iPtr = (Interp *) interp; Tcl_CallFrame *framePtr; - ByteCode *codePtr = bodyPtr->internalRep.twoPtrValue.ptr1; + ByteCode *codePtr; + + ByteCodeGetIntRep(bodyPtr, &tclByteCodeType, codePtr); /* * If necessary, compile the procedure's body. The compiler will allocate @@ -1974,7 +1980,7 @@ TclProcCompileProc( * are not recompiled, even if things have changed. */ - if (bodyPtr->typePtr == &tclByteCodeType) { + if (codePtr != NULL) { if (((Interp *) *codePtr->interpHandle == iPtr) && (codePtr->compileEpoch == iPtr->compileEpoch) && (codePtr->nsPtr == nsPtr) @@ -1994,10 +2000,11 @@ TclProcCompileProc( codePtr->nsPtr = nsPtr; } else { TclFreeIntRep(bodyPtr); + codePtr = NULL; } } - if (bodyPtr->typePtr != &tclByteCodeType) { + if (codePtr == NULL) { Tcl_HashEntry *hePtr; #ifdef TCL_COMPILE_DEBUG @@ -2374,7 +2381,8 @@ ProcBodyDup( Tcl_Obj *srcPtr, /* Object to copy. */ Tcl_Obj *dupPtr) /* Target object for the duplication. */ { - Proc *procPtr = srcPtr->internalRep.twoPtrValue.ptr1; + Proc *procPtr; + ProcGetIntRep(srcPtr, procPtr); ProcSetIntRep(dupPtr, procPtr); } @@ -2402,7 +2410,9 @@ static void ProcBodyFree( Tcl_Obj *objPtr) /* The object to clean up. */ { - Proc *procPtr = objPtr->internalRep.twoPtrValue.ptr1; + Proc *procPtr; + + ProcGetIntRep(objPtr, procPtr); if (procPtr->refCount-- <= 1) { TclProcCleanupProc(procPtr); -- cgit v0.12 From 6c3864d50e67e78a0f42fdf677ccba994a66dfe2 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 10 May 2016 17:22:14 +0000 Subject: Revise encodingType to use proposed routines. --- generic/tclEncoding.c | 36 ++++++++++++++++++++++++++---------- 1 file changed, 26 insertions(+), 10 deletions(-) diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 32055a3..b3ad1e4 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -279,6 +279,21 @@ static int Iso88591ToUtfProc(ClientData clientData, static const Tcl_ObjType encodingType = { "encoding", FreeEncodingIntRep, DupEncodingIntRep, NULL, NULL }; +#define EncodingSetIntRep(objPtr, encoding) \ + do { \ + Tcl_ObjIntRep ir; \ + ir.twoPtrValue.ptr1 = (encoding); \ + ir.twoPtrValue.ptr2 = NULL; \ + Tcl_StoreIntRep((objPtr), &encodingType, &ir); \ + } while (0) + +#define EncodingGetIntRep(objPtr, encoding) \ + do { \ + const Tcl_ObjIntRep *irPtr; \ + irPtr = Tcl_FetchIntRep ((objPtr), &encodingType); \ + (encoding) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \ + } while (0) + /* *---------------------------------------------------------------------- @@ -305,17 +320,16 @@ Tcl_GetEncodingFromObj( Tcl_Obj *objPtr, Tcl_Encoding *encodingPtr) { + Tcl_Encoding encoding; const char *name = Tcl_GetString(objPtr); - if (objPtr->typePtr != &encodingType) { - Tcl_Encoding encoding = Tcl_GetEncoding(interp, name); - + EncodingGetIntRep(objPtr, encoding); + if (encoding == NULL) { + encoding = Tcl_GetEncoding(interp, name); if (encoding == NULL) { return TCL_ERROR; } - TclFreeIntRep(objPtr); - objPtr->internalRep.twoPtrValue.ptr1 = encoding; - objPtr->typePtr = &encodingType; + EncodingSetIntRep(objPtr, encoding); } *encodingPtr = Tcl_GetEncoding(NULL, name); return TCL_OK; @@ -335,8 +349,10 @@ static void FreeEncodingIntRep( Tcl_Obj *objPtr) { - Tcl_FreeEncoding(objPtr->internalRep.twoPtrValue.ptr1); - objPtr->typePtr = NULL; + Tcl_Encoding encoding; + + EncodingGetIntRep(objPtr, encoding); + Tcl_FreeEncoding(encoding); } /* @@ -354,8 +370,8 @@ DupEncodingIntRep( Tcl_Obj *srcPtr, Tcl_Obj *dupPtr) { - dupPtr->internalRep.twoPtrValue.ptr1 = Tcl_GetEncoding(NULL, srcPtr->bytes); - dupPtr->typePtr = &encodingType; + Tcl_Encoding encoding = Tcl_GetEncoding(NULL, srcPtr->bytes); + EncodingSetIntRep(dupPtr, encoding); } /* -- cgit v0.12 From 694ffb74542176b67c5cddf7b421e63bf851411b Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 12 Jul 2016 21:32:25 +0000 Subject: convert ensembleCmdType to new interfaces. --- generic/tclEnsemble.c | 40 +++++++++++++++++++++++++++------------- 1 file changed, 27 insertions(+), 13 deletions(-) diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 2766769..de75df3 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -86,6 +86,21 @@ static const Tcl_ObjType ensembleCmdType = { NULL /* setFromAnyProc */ }; +#define ECRSetIntRep(objPtr, ecRepPtr) \ + do { \ + Tcl_ObjIntRep ir; \ + ir.twoPtrValue.ptr1 = (ecRepPtr); \ + ir.twoPtrValue.ptr2 = NULL; \ + Tcl_StoreIntRep((objPtr), &ensembleCmdType, &ir); \ + } while (0) + +#define ECRGetIntRep(objPtr, ecRepPtr) \ + do { \ + const Tcl_ObjIntRep *irPtr; \ + irPtr = Tcl_FetchIntRep((objPtr), &ensembleCmdType); \ + (ecRepPtr) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \ + } while (0) + /* * The internal rep for caching ensemble subcommand lookups and * spell corrections. @@ -1717,10 +1732,10 @@ NsEnsembleImplementationCmdNR( * check here, and if we're still valid, we can jump straight to the * part where we do the invocation of the subcommand. */ + EnsembleCmdRep *ensembleCmd; - if (subObj->typePtr==&ensembleCmdType){ - EnsembleCmdRep *ensembleCmd = subObj->internalRep.twoPtrValue.ptr1; - + ECRGetIntRep(subObj, ensembleCmd); + if (ensembleCmd) { if (ensembleCmd->epoch == ensemblePtr->epoch && ensembleCmd->token == (Command *)ensemblePtr->token) { prefixObj = Tcl_GetHashValue(ensembleCmd->hPtr); @@ -2346,8 +2361,8 @@ MakeCachedEnsembleCommand( { register EnsembleCmdRep *ensembleCmd; - if (objPtr->typePtr == &ensembleCmdType) { - ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1; + ECRGetIntRep(objPtr, ensembleCmd); + if (ensembleCmd) { TclCleanupCommandMacro(ensembleCmd->token); if (ensembleCmd->fix) { Tcl_DecrRefCount(ensembleCmd->fix); @@ -2358,10 +2373,8 @@ MakeCachedEnsembleCommand( * our own. */ - TclFreeIntRep(objPtr); ensembleCmd = ckalloc(sizeof(EnsembleCmdRep)); - objPtr->internalRep.twoPtrValue.ptr1 = ensembleCmd; - objPtr->typePtr = &ensembleCmdType; + ECRSetIntRep(objPtr, ensembleCmd); } /* @@ -2754,14 +2767,14 @@ static void FreeEnsembleCmdRep( Tcl_Obj *objPtr) { - EnsembleCmdRep *ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1; + EnsembleCmdRep *ensembleCmd; + ECRGetIntRep(objPtr, ensembleCmd); TclCleanupCommandMacro(ensembleCmd->token); if (ensembleCmd->fix) { Tcl_DecrRefCount(ensembleCmd->fix); } ckfree(ensembleCmd); - objPtr->typePtr = NULL; } /* @@ -2787,11 +2800,12 @@ DupEnsembleCmdRep( Tcl_Obj *objPtr, Tcl_Obj *copyPtr) { - EnsembleCmdRep *ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1; + EnsembleCmdRep *ensembleCmd; EnsembleCmdRep *ensembleCopy = ckalloc(sizeof(EnsembleCmdRep)); - copyPtr->typePtr = &ensembleCmdType; - copyPtr->internalRep.twoPtrValue.ptr1 = ensembleCopy; + ECRGetIntRep(objPtr, ensembleCmd); + ECRSetIntRep(copyPtr, ensembleCopy); + ensembleCopy->epoch = ensembleCmd->epoch; ensembleCopy->token = ensembleCmd->token; ensembleCopy->token->refCount++; -- cgit v0.12 From ca5093b1ea05fc1e638c182e031710c434bfd30a Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 12 Jul 2016 21:36:13 +0000 Subject: Prefer removal of just known invalid intrep over destruction of all intreps. --- generic/tclAssembly.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 8540b59..1529198 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -867,7 +867,7 @@ CompileAssembleObj( * Not valid, so free it and regenerate. */ - TclFreeIntRep(objPtr); + Tcl_StoreIntRep(objPtr, &assembleCodeType, NULL); } /* -- cgit v0.12 From e2e1132ebacfe2105c78d5104ff9b24aff2290b4 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 12 Jul 2016 21:38:25 +0000 Subject: Prefer removal of just known invalid interp over destruction of all intreps. --- generic/tclCompile.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index cdd75d9..a3722f7 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1313,7 +1313,7 @@ CompileSubstObj( || (codePtr->nsEpoch != nsPtr->resolverEpoch) || (codePtr->localCachePtr != iPtr->varFramePtr->localCachePtr)) { - TclFreeIntRep(objPtr); + Tcl_StoreIntRep(objPtr, &substCodeType, NULL); codePtr = NULL; } } -- cgit v0.12 From 9a0684671aa9a92a1d8b4037507484c07cdf3a3d Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 12 Jul 2016 21:41:42 +0000 Subject: More of the same. --- generic/tclExecute.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 3b23b80..a754474 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -1538,7 +1538,7 @@ CompileExprObj( || (codePtr->nsPtr != namespacePtr) || (codePtr->nsEpoch != namespacePtr->resolverEpoch) || (codePtr->localCachePtr != iPtr->varFramePtr->localCachePtr)) { - TclFreeIntRep(objPtr); + Tcl_StoreIntRep(objPtr, &exprCodeType, NULL); codePtr = NULL; } } -- cgit v0.12 From 792e537014155639518f89b8c2e24abb8cd85d5c Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 13 Jul 2016 15:43:44 +0000 Subject: another one --- generic/tclNamesp.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 43f2c1a..dd6ba55 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -2907,7 +2907,7 @@ GetNamespaceFromObj( *nsPtrPtr = (Tcl_Namespace *) nsPtr; return TCL_OK; } - TclFreeIntRep(objPtr); + Tcl_StoreIntRep(objPtr, &nsNameType, NULL); } if (SetNsNameFromAny(interp, objPtr) == TCL_OK) { NsNameGetIntRep(objPtr, resNamePtr); -- cgit v0.12 From a13a6885072371776b76ca638da45c6d274a79db Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 13 Jul 2016 16:02:04 +0000 Subject: and another --- generic/tclOOCall.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c index 0a265e5..d660c58 100644 --- a/generic/tclOOCall.c +++ b/generic/tclOOCall.c @@ -966,7 +966,7 @@ TclOOGetCallContext( callPtr->refCount++; goto returnContext; } - Tcl_FreeIntRep(cacheInThisObj); + Tcl_StoreIntRep(cacheInThisObj, &methodNameType, NULL); } if (oPtr->flags & USE_CLASS_CACHE) { -- cgit v0.12 From 059410842de73f5f43cf23d263880114756fbf20 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 13 Jul 2016 17:02:24 +0000 Subject: another --- generic/tclOOMethod.c | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index 3d9fc35..ce397f8 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -791,6 +791,7 @@ PushMethodCallFrame( register int result; const char *namePtr; CallFrame **framePtrPtr = &fdPtr->framePtr; + ByteCode *codePtr; /* * Compute basic information on the basis of the type of method it is. @@ -856,10 +857,8 @@ PushMethodCallFrame( * alternative is *so* slow... */ - if (pmPtr->procPtr->bodyPtr->typePtr == &tclByteCodeType) { - ByteCode *codePtr = - pmPtr->procPtr->bodyPtr->internalRep.twoPtrValue.ptr1; - + ByteCodeGetIntRep(pmPtr->procPtr->bodyPtr, &tclByteCodeType, codePtr); + if (codePtr) { codePtr->nsPtr = nsPtr; } result = TclProcCompileProc(interp, pmPtr->procPtr, @@ -1314,7 +1313,7 @@ CloneProcedureMethod( */ bodyObj = Tcl_DuplicateObj(pmPtr->procPtr->bodyPtr); - TclFreeIntRep(bodyObj); + Tcl_StoreIntRep(pmPtr->procPtr->bodyPtr, &tclByteCodeType, NULL); /* * Create the actual copy of the method record, manufacturing a new proc -- cgit v0.12 From 020fdb84f40bbcafa94b79e7d30d84f55ccc3db2 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 13 Jul 2016 17:25:47 +0000 Subject: yup --- generic/tclProc.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclProc.c b/generic/tclProc.c index a01a314..bc6cc45 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -2000,7 +2000,7 @@ TclProcCompileProc( codePtr->compileEpoch = iPtr->compileEpoch; codePtr->nsPtr = nsPtr; } else { - TclFreeIntRep(bodyPtr); + Tcl_StoreIntRep(bodyPtr, &tclByteCodeType, NULL); codePtr = NULL; } } -- cgit v0.12 From df55f87e2d98f6a9a46a12805c38f47b9df8c626 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 18 Jul 2016 20:59:52 +0000 Subject: Half convert "chan" Tcl_ObjType to new interfaces. --- generic/tclIO.c | 23 +++++++++++++++++------ 1 file changed, 17 insertions(+), 6 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 80f6fa4..d7bd4af 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -337,6 +337,13 @@ static const Tcl_ObjType chanObjType = { NULL /* setFromAnyProc */ }; +#define ChanGetIntRep(objPtr, resPtr) \ + do { \ + const Tcl_ObjIntRep *irPtr; \ + irPtr = Tcl_FetchIntRep((objPtr), &chanObjType); \ + (resPtr) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \ + } while (0) + #define BUSY_STATE(st, fl) \ ((((st)->csPtrR) && ((fl) & TCL_READABLE)) || \ (((st)->csPtrW) && ((fl) & TCL_WRITABLE))) @@ -1501,12 +1508,12 @@ TclGetChannelFromObj( return TCL_ERROR; } - if (objPtr->typePtr == &chanObjType) { + ChanGetIntRep(objPtr, resPtr); + if (resPtr) { /* * Confirm validity of saved lookup results. */ - resPtr = (ResolvedChanName *) objPtr->internalRep.twoPtrValue.ptr1; statePtr = resPtr->statePtr; if ((resPtr->interp == interp) /* Same interp context */ /* No epoch change in channel since lookup */ @@ -1521,7 +1528,7 @@ TclGetChannelFromObj( if (chan == NULL) { if (resPtr) { - FreeChannelIntRep(objPtr); + Tcl_StoreIntRep(objPtr, &chanObjType, NULL); } return TCL_ERROR; } @@ -11164,7 +11171,10 @@ DupChannelIntRep( register Tcl_Obj *copyPtr) /* Object with internal rep to set. Must not * currently have an internal rep.*/ { - ResolvedChanName *resPtr = srcPtr->internalRep.twoPtrValue.ptr1; + ResolvedChanName *resPtr; + + ChanGetIntRep(srcPtr, resPtr); + assert(resPtr); resPtr->refCount++; copyPtr->internalRep.twoPtrValue.ptr1 = resPtr; @@ -11191,9 +11201,10 @@ static void FreeChannelIntRep( Tcl_Obj *objPtr) /* Object with internal rep to free. */ { - ResolvedChanName *resPtr = objPtr->internalRep.twoPtrValue.ptr1; + ResolvedChanName *resPtr; - objPtr->typePtr = NULL; + ChanGetIntRep(objPtr, resPtr); + assert(resPtr); if (--resPtr->refCount) { return; } -- cgit v0.12 From 40d62156ac38bc55dbe904eb9ed2e1a37fb6ba42 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 18 Jul 2016 21:53:51 +0000 Subject: Second half "chan" Tcl_ObjType conversion. Mistake avoided this time. --- generic/tclIO.c | 22 ++++++++++++---------- 1 file changed, 12 insertions(+), 10 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index d7bd4af..5f479f4 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -337,6 +337,15 @@ static const Tcl_ObjType chanObjType = { NULL /* setFromAnyProc */ }; +#define ChanSetIntRep(objPtr, resPtr) \ + do { \ + Tcl_ObjIntRep ir; \ + (resPtr)->refCount++; \ + ir.twoPtrValue.ptr1 = (resPtr); \ + ir.twoPtrValue.ptr2 = NULL; \ + Tcl_StoreIntRep((objPtr), &chanObjType, &ir); \ + } while (0) + #define ChanGetIntRep(objPtr, resPtr) \ do { \ const Tcl_ObjIntRep *irPtr; \ @@ -1536,14 +1545,10 @@ TclGetChannelFromObj( if (resPtr && resPtr->refCount == 1) { /* Re-use the ResolvedCmdName struct */ Tcl_Release((ClientData) resPtr->statePtr); - } else { - TclFreeIntRep(objPtr); - resPtr = (ResolvedChanName *) ckalloc(sizeof(ResolvedChanName)); - resPtr->refCount = 1; - objPtr->internalRep.twoPtrValue.ptr1 = (ClientData) resPtr; - objPtr->typePtr = &chanObjType; + resPtr->refCount = 0; + ChanSetIntRep(objPtr, resPtr); /* Overwrites, if needed */ } statePtr = ((Channel *)chan)->state; resPtr->statePtr = statePtr; @@ -11175,10 +11180,7 @@ DupChannelIntRep( ChanGetIntRep(srcPtr, resPtr); assert(resPtr); - - resPtr->refCount++; - copyPtr->internalRep.twoPtrValue.ptr1 = resPtr; - copyPtr->typePtr = srcPtr->typePtr; + ChanSetIntRep(copyPtr, resPtr); } /* -- cgit v0.12 From f211f9c476cee29c88e92a8f9415793f6a583203 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 20 Jul 2016 15:31:35 +0000 Subject: Convert the "localVarName" type to the proposed interfaces. --- generic/tclVar.c | 89 ++++++++++++++++++++++++++++++++++++-------------------- 1 file changed, 58 insertions(+), 31 deletions(-) diff --git a/generic/tclVar.c b/generic/tclVar.c index 2248316..2bc2243 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -226,6 +226,24 @@ static const Tcl_ObjType localVarNameType = { FreeLocalVarName, DupLocalVarName, NULL, NULL }; +#define LocalSetIntRep(objPtr, index, namePtr) \ + do { \ + Tcl_ObjIntRep ir; \ + Tcl_Obj *ptr = (namePtr); \ + if (ptr) {Tcl_IncrRefCount(ptr);} \ + ir.twoPtrValue.ptr1 = ptr; \ + ir.twoPtrValue.ptr2 = INT2PTR(index); \ + Tcl_StoreIntRep((objPtr), &localVarNameType, &ir); \ + } while (0) + +#define LocalGetIntRep(objPtr, index, name) \ + do { \ + const Tcl_ObjIntRep *irPtr; \ + irPtr = Tcl_FetchIntRep((objPtr), &localVarNameType); \ + (name) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \ + (index) = irPtr ? PTR2INT(irPtr->twoPtrValue.ptr2) : -1; \ + } while (0) + static const Tcl_ObjType parsedVarNameType = { "parsedVarName", FreeParsedVarName, DupParsedVarName, NULL, NULL @@ -507,17 +525,19 @@ TclObjLookupVarEx( int index, len1, len2; int parsed = 0; Tcl_Obj *objPtr; - const Tcl_ObjType *typePtr = part1Ptr->typePtr; + const Tcl_ObjType *typePtr; const char *errMsg = NULL; CallFrame *varFramePtr = iPtr->varFramePtr; const char *part2 = part2Ptr? TclGetString(part2Ptr):NULL; - *arrayPtrPtr = NULL; + int localIndex; + Tcl_Obj *namePtr; - if (typePtr == &localVarNameType) { - int localIndex; + *arrayPtrPtr = NULL; - localVarNameTypeHandling: - localIndex = PTR2INT(part1Ptr->internalRep.twoPtrValue.ptr2); + restart: + typePtr = part1Ptr->typePtr; + LocalGetIntRep(part1Ptr, localIndex, namePtr); + if (localIndex >= 0) { if (HasLocalVars(varFramePtr) && !(flags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY)) && (localIndex < varFramePtr->numCompiledLocals)) { @@ -525,7 +545,6 @@ TclObjLookupVarEx( * Use the cached index if the names coincide. */ - Tcl_Obj *namePtr = part1Ptr->internalRep.twoPtrValue.ptr1; Tcl_Obj *checkNamePtr = localName(iPtr->varFramePtr, localIndex); if ((!namePtr && (checkNamePtr == part1Ptr)) || @@ -543,6 +562,7 @@ TclObjLookupVarEx( */ if (typePtr == &parsedVarNameType) { + parsed = 1; if (part1Ptr->internalRep.twoPtrValue.ptr1 != NULL) { if (part2Ptr != NULL) { /* @@ -559,12 +579,8 @@ TclObjLookupVarEx( } part2Ptr = part1Ptr->internalRep.twoPtrValue.ptr2; part1Ptr = part1Ptr->internalRep.twoPtrValue.ptr1; - typePtr = part1Ptr->typePtr; - if (typePtr == &localVarNameType) { - goto localVarNameTypeHandling; - } + goto restart; } - parsed = 1; } part1 = TclGetStringFromObj(part1Ptr, &len1); @@ -658,18 +674,30 @@ TclObjLookupVarEx( */ Tcl_Obj *cachedNamePtr = localName(iPtr->varFramePtr, index); - part1Ptr->typePtr = &localVarNameType; - if (part1Ptr != cachedNamePtr) { - part1Ptr->internalRep.twoPtrValue.ptr1 = cachedNamePtr; - Tcl_IncrRefCount(cachedNamePtr); - if (cachedNamePtr->typePtr != &localVarNameType - || cachedNamePtr->internalRep.twoPtrValue.ptr1 != NULL) { - TclFreeIntRep(cachedNamePtr); - } + if (part1Ptr == cachedNamePtr) { + cachedNamePtr = NULL; } else { - part1Ptr->internalRep.twoPtrValue.ptr1 = NULL; + /* + * [80304238ac] Trickiness here. We will store and incr the + * refcount on cachedNamePtr. Trouble is that it's possible + * (see test var-22.1) for cachedNamePtr to have an intrep + * that contains a stored and refcounted part1Ptr. This + * would be a reference cycle which leads to a memory leak. + * + * The solution here is to wipe away all intrep(s) in + * cachedNamePtr and leave it as string only. This is + * radical and destructive, so a better idea would be welcome. + */ + TclFreeIntRep(cachedNamePtr); + + /* + * Now go ahead and convert it the the "localVarName" type, + * since we suspect at least some use of the value as a + * varname and we want to resolve it quickly. + */ + LocalSetIntRep(cachedNamePtr, index, NULL); } - part1Ptr->internalRep.twoPtrValue.ptr2 = INT2PTR(index); + LocalSetIntRep(part1Ptr, index, cachedNamePtr); } else { /* * At least mark part1Ptr as already parsed. @@ -5299,12 +5327,14 @@ static void FreeLocalVarName( Tcl_Obj *objPtr) { - Tcl_Obj *namePtr = objPtr->internalRep.twoPtrValue.ptr1; + int index; + Tcl_Obj *namePtr; + + LocalGetIntRep(objPtr, index, namePtr); if (namePtr) { Tcl_DecrRefCount(namePtr); } - objPtr->typePtr = NULL; } static void @@ -5312,17 +5342,14 @@ DupLocalVarName( Tcl_Obj *srcPtr, Tcl_Obj *dupPtr) { - Tcl_Obj *namePtr = srcPtr->internalRep.twoPtrValue.ptr1; + int index; + Tcl_Obj *namePtr; + LocalGetIntRep(srcPtr, index, namePtr); if (!namePtr) { namePtr = srcPtr; } - dupPtr->internalRep.twoPtrValue.ptr1 = namePtr; - Tcl_IncrRefCount(namePtr); - - dupPtr->internalRep.twoPtrValue.ptr2 = - srcPtr->internalRep.twoPtrValue.ptr2; - dupPtr->typePtr = &localVarNameType; + LocalSetIntRep(dupPtr, index, namePtr); } /* -- cgit v0.12 From 3e5f21836fec72d9b61ae643ae6fcf903d388b75 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 20 Jul 2016 19:47:31 +0000 Subject: Revise "parsedVarName" type to use proposed interfaces. --- generic/tclVar.c | 80 +++++++++++++++++++++++++++++--------------------------- 1 file changed, 41 insertions(+), 39 deletions(-) diff --git a/generic/tclVar.c b/generic/tclVar.c index e9f2632..9df1633 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -249,6 +249,27 @@ static const Tcl_ObjType parsedVarNameType = { FreeParsedVarName, DupParsedVarName, NULL, NULL }; +#define ParsedSetIntRep(objPtr, arrayPtr, elem) \ + do { \ + Tcl_ObjIntRep ir; \ + Tcl_Obj *ptr1 = (arrayPtr); \ + Tcl_Obj *ptr2 = (elem); \ + if (ptr1) {Tcl_IncrRefCount(ptr1);} \ + if (ptr2) {Tcl_IncrRefCount(ptr2);} \ + ir.twoPtrValue.ptr1 = ptr1; \ + ir.twoPtrValue.ptr2 = ptr2; \ + Tcl_StoreIntRep((objPtr), &parsedVarNameType, &ir); \ + } while (0) + +#define ParsedGetIntRep(objPtr, parsed, array, elem) \ + do { \ + const Tcl_ObjIntRep *irPtr; \ + irPtr = Tcl_FetchIntRep((objPtr), &parsedVarNameType); \ + (parsed) = (irPtr != NULL); \ + (array) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \ + (elem) = irPtr ? irPtr->twoPtrValue.ptr2 : NULL; \ + } while (0) + Var * TclVarHashCreateVar( @@ -435,9 +456,8 @@ TclLookupVar( * * Side effects: * New hashtable entries may be created if createPart1 or createPart2 - * are 1. The object part1Ptr is converted to one of localVarNameType, - * tclNsVarNameType or parsedVarNameType and caches as much of the - * lookup as it can. + * are 1. The object part1Ptr is converted to one of localVarNameType + * or parsedVarNameType and caches as much of the lookup as it can. * When createPart1 is 1, callers must IncrRefCount part1Ptr if they * plan to DecrRefCount it. * @@ -524,15 +544,13 @@ TclObjLookupVarEx( * structure. */ const char *errMsg = NULL; int index, parsed = 0; - const Tcl_ObjType *typePtr; int localIndex; - Tcl_Obj *namePtr; + Tcl_Obj *namePtr, *arrayPtr, *elem; *arrayPtrPtr = NULL; restart: - typePtr = part1Ptr->typePtr; LocalGetIntRep(part1Ptr, localIndex, namePtr); if (localIndex >= 0) { if (HasLocalVars(varFramePtr) @@ -554,13 +572,11 @@ TclObjLookupVarEx( } /* - * If part1Ptr is a parsedVarNameType, separate it into the pre-parsed - * parts. + * If part1Ptr is a parsedVarNameType, retrieve the pre-parsed parts. */ - if (typePtr == &parsedVarNameType) { - parsed = 1; - if (part1Ptr->internalRep.twoPtrValue.ptr1 != NULL) { + ParsedGetIntRep(part1Ptr, parsed, arrayPtr, elem); + if (parsed && arrayPtr) { if (part2Ptr != NULL) { /* * ERROR: part1Ptr is already an array element, cannot specify @@ -574,10 +590,9 @@ TclObjLookupVarEx( } return NULL; } - part2Ptr = part1Ptr->internalRep.twoPtrValue.ptr2; - part1Ptr = part1Ptr->internalRep.twoPtrValue.ptr1; + part2Ptr = elem; + part1Ptr = arrayPtr; goto restart; - } } if (!parsed) { @@ -594,8 +609,6 @@ TclObjLookupVarEx( const char *part2 = strchr(part1, '('); if (part2) { - Tcl_Obj *arrayPtr; - if (part2Ptr != NULL) { if (flags & TCL_LEAVE_ERR_MSG) { TclObjVarErrMsg(interp, part1Ptr, part2Ptr, msg, @@ -609,13 +622,7 @@ TclObjLookupVarEx( arrayPtr = Tcl_NewStringObj(part1, (part2 - part1)); part2Ptr = Tcl_NewStringObj(part2 + 1, len - (part2 - part1) - 2); - TclFreeIntRep(part1Ptr); - - Tcl_IncrRefCount(arrayPtr); - part1Ptr->internalRep.twoPtrValue.ptr1 = arrayPtr; - Tcl_IncrRefCount(part2Ptr); - part1Ptr->internalRep.twoPtrValue.ptr2 = part2Ptr; - part1Ptr->typePtr = &parsedVarNameType; + ParsedSetIntRep(part1Ptr, arrayPtr, part2Ptr); part1Ptr = arrayPtr; } @@ -643,7 +650,6 @@ TclObjLookupVarEx( * Cache the newly found variable if possible. */ - TclFreeIntRep(part1Ptr); if (index >= 0) { /* * An indexed local variable. @@ -679,9 +685,7 @@ TclObjLookupVarEx( * At least mark part1Ptr as already parsed. */ - part1Ptr->typePtr = &parsedVarNameType; - part1Ptr->internalRep.twoPtrValue.ptr1 = NULL; - part1Ptr->internalRep.twoPtrValue.ptr2 = NULL; + ParsedSetIntRep(part1Ptr, NULL, NULL); } donePart1: @@ -5342,14 +5346,16 @@ static void FreeParsedVarName( Tcl_Obj *objPtr) { - register Tcl_Obj *arrayPtr = objPtr->internalRep.twoPtrValue.ptr1; - register Tcl_Obj *elem = objPtr->internalRep.twoPtrValue.ptr2; + register Tcl_Obj *arrayPtr, *elem; + int parsed; + + ParsedGetIntRep(objPtr, parsed, arrayPtr, elem); + parsed++; /* Silence compiler. */ if (arrayPtr != NULL) { TclDecrRefCount(arrayPtr); TclDecrRefCount(elem); } - objPtr->typePtr = NULL; } static void @@ -5357,17 +5363,13 @@ DupParsedVarName( Tcl_Obj *srcPtr, Tcl_Obj *dupPtr) { - register Tcl_Obj *arrayPtr = srcPtr->internalRep.twoPtrValue.ptr1; - register Tcl_Obj *elem = srcPtr->internalRep.twoPtrValue.ptr2; + register Tcl_Obj *arrayPtr, *elem; + int parsed; - if (arrayPtr != NULL) { - Tcl_IncrRefCount(arrayPtr); - Tcl_IncrRefCount(elem); - } + ParsedGetIntRep(srcPtr, parsed, arrayPtr, elem); - dupPtr->internalRep.twoPtrValue.ptr1 = arrayPtr; - dupPtr->internalRep.twoPtrValue.ptr2 = elem; - dupPtr->typePtr = &parsedVarNameType; + parsed++; /* Silence compiler. */ + ParsedSetIntRep(dupPtr, arrayPtr, elem); } /* -- cgit v0.12 From d0002e5394b792fd71045acc4a43ef1c500009ee Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 7 Oct 2016 16:36:42 +0000 Subject: New routine Tcl_HasStringRep() and first conversion of callers. --- generic/tcl.decls | 3 +++ generic/tclBasic.c | 14 ++++++++------ generic/tclDecls.h | 5 +++++ generic/tclInt.h | 12 ++++++++++++ generic/tclObj.c | 19 +++++++++++++++++++ generic/tclStubInit.c | 1 + 6 files changed, 48 insertions(+), 6 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index 953102b..d435fe4 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2341,6 +2341,9 @@ declare 634 { void Tcl_StoreIntRep(Tcl_Obj *objPtr, const Tcl_ObjType *typePtr, const Tcl_ObjIntRep *irPtr) } +declare 635 { + int Tcl_HasStringRep(Tcl_Obj *objPtr) +} # ----- BASELINE -- FOR -- 8.7.0 ----- # diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 9de8d1d..e17a831 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -5791,7 +5791,7 @@ TclArgumentGet( * up by the caller. It knows better than us. */ - if ((obj->bytes == NULL) || TclListObjIsCanonical(obj)) { + if (!TclHasStringRep(obj) || TclListObjIsCanonical(obj)) { return; } @@ -7413,14 +7413,16 @@ ExprAbsFunc( if (l > (long)0) { goto unChanged; } else if (l == (long)0) { - const char *string = objv[1]->bytes; - if (string) { - while (*string != '0') { - if (*string == '-') { + if (TclHasStringRep(objv[1])) { + int numBytes; + const char *bytes = TclGetStringFromObj(objv[1], &numBytes); + + while (numBytes) { + if (*bytes == '-') { Tcl_SetObjResult(interp, Tcl_NewLongObj(0)); return TCL_OK; } - string++; + bytes++; numBytes--; } } goto unChanged; diff --git a/generic/tclDecls.h b/generic/tclDecls.h index ed1e326..71598ab 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1828,6 +1828,8 @@ EXTERN Tcl_ObjIntRep * Tcl_FetchIntRep(Tcl_Obj *objPtr, EXTERN void Tcl_StoreIntRep(Tcl_Obj *objPtr, const Tcl_ObjType *typePtr, const Tcl_ObjIntRep *irPtr); +/* 635 */ +EXTERN int Tcl_HasStringRep(Tcl_Obj *objPtr); typedef struct { const struct TclPlatStubs *tclPlatStubs; @@ -2498,6 +2500,7 @@ typedef struct TclStubs { char * (*tcl_InitStringRep) (Tcl_Obj *objPtr, const char *bytes, unsigned int numBytes); /* 632 */ Tcl_ObjIntRep * (*tcl_FetchIntRep) (Tcl_Obj *objPtr, const Tcl_ObjType *typePtr); /* 633 */ void (*tcl_StoreIntRep) (Tcl_Obj *objPtr, const Tcl_ObjType *typePtr, const Tcl_ObjIntRep *irPtr); /* 634 */ + int (*tcl_HasStringRep) (Tcl_Obj *objPtr); /* 635 */ } TclStubs; extern const TclStubs *tclStubsPtr; @@ -3798,6 +3801,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_FetchIntRep) /* 633 */ #define Tcl_StoreIntRep \ (tclStubsPtr->tcl_StoreIntRep) /* 634 */ +#define Tcl_HasStringRep \ + (tclStubsPtr->tcl_HasStringRep) /* 635 */ #endif /* defined(USE_TCL_STUBS) */ diff --git a/generic/tclInt.h b/generic/tclInt.h index 6796949..89d9f32 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4295,6 +4295,18 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, /* *---------------------------------------------------------------- + * Macro used by the Tcl core to test whether an object has a + * string representation (or is a 'pure' internal value). + * The ANSI C "prototype" for this macro is: + * + * MODULE_SCOPE int TclHasStringRep(Tcl_Obj *objPtr); + *---------------------------------------------------------------- + */ + +#define TclHasStringRep(objPtr) ((objPtr)->bytes != NULL) + +/* + *---------------------------------------------------------------- * Macros used by the Tcl core to grow Tcl_Token arrays. They use the same * growth algorithm as used in tclStringObj.c for growing strings. The ANSI C * "prototype" for this macro is: diff --git a/generic/tclObj.c b/generic/tclObj.c index 368ba52..387f92b 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -1810,6 +1810,25 @@ Tcl_InvalidateStringRep( /* *---------------------------------------------------------------------- * + * Tcl_HasStringRep -- + * + * This function reports whether object has a string representation. + * + * Results: + * Boolean. + *---------------------------------------------------------------------- + */ + +int +Tcl_HasStringRep( + Tcl_Obj *objPtr) /* Object to test */ +{ + return TclHasStringRep(objPtr); +} + +/* + *---------------------------------------------------------------------- + * * Tcl_StoreIntRep -- * * This function is called to set the object's internal diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 2af47b7..c5c8e80 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -1419,6 +1419,7 @@ const TclStubs tclStubs = { Tcl_InitStringRep, /* 632 */ Tcl_FetchIntRep, /* 633 */ Tcl_StoreIntRep, /* 634 */ + Tcl_HasStringRep, /* 635 */ }; /* !END!: Do not edit above this line. */ -- cgit v0.12 From 7b2a90493f10dc61b00ab07a3057b23b4b2dc7d2 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 7 Oct 2016 19:04:44 +0000 Subject: Use the new purity test. --- generic/tclCmdMZ.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 3b81cbe..9398e47 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -1876,7 +1876,8 @@ StringMapCmd( * inconsistencies (see test string-10.20.1 for illustration why!) */ - if (Tcl_FetchIntRep(objv[objc-2], &tclDictType) && objv[objc-2]->bytes == NULL){ + if (!TclHasStringRep(objv[objc-2]) + && Tcl_FetchIntRep(objv[objc-2], &tclDictType)){ int i, done; Tcl_DictSearch search; -- cgit v0.12 From ec7df3f449d90d7fd7a81b27d7b6264f13596629 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 7 Oct 2016 21:06:04 +0000 Subject: Purge more direct accesses to bytes field. --- generic/tclCompExpr.c | 8 +++++--- generic/tclDisassemble.c | 4 +--- generic/tclEncoding.c | 2 +- generic/tclListObj.c | 2 +- 4 files changed, 8 insertions(+), 8 deletions(-) diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index 83bb883..7ad39f9 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -2476,11 +2476,13 @@ CompileExprTree( * already, then use it to share via the literal table. */ - if (objPtr->bytes) { + if (TclHasStringRep(objPtr)) { Tcl_Obj *tableValue; + int numBytes; + const char *bytes + = Tcl_GetStringFromObj(objPtr, &numBytes); - index = TclRegisterLiteral(envPtr, objPtr->bytes, - objPtr->length, 0); + index = TclRegisterLiteral(envPtr, bytes, numBytes, 0); tableValue = TclFetchLiteral(envPtr, index); if ((tableValue->typePtr == NULL) && (objPtr->typePtr != NULL)) { diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index 92e5c2e..a727413 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -815,9 +815,7 @@ TclNewInstNameObj( { Tcl_Obj *objPtr = Tcl_NewObj(); - /* Optimized Tcl_InvalidateStringRep */ - objPtr->bytes = NULL; - + TclInvalidateStringRep(objPtr); InstNameSetIntRep(objPtr, (long) inst); return objPtr; diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 5db6859..6beb10c 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -370,7 +370,7 @@ DupEncodingIntRep( Tcl_Obj *srcPtr, Tcl_Obj *dupPtr) { - Tcl_Encoding encoding = Tcl_GetEncoding(NULL, srcPtr->bytes); + Tcl_Encoding encoding = Tcl_GetEncoding(NULL, TclGetString(srcPtr)); EncodingSetIntRep(dupPtr, encoding); } diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 0b6473b..e2e0f63 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -1877,7 +1877,7 @@ SetListFromAny( * describe duplicate keys). */ - if (Tcl_FetchIntRep(objPtr, &tclDictType) && !objPtr->bytes) { + if (!TclHasStringRep(objPtr) && Tcl_FetchIntRep(objPtr, &tclDictType)) { Tcl_Obj *keyPtr, *valuePtr; Tcl_DictSearch search; int done, size; -- cgit v0.12 From e97fab49d3893f5cc7879b765cc345bf32349096 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 12 Oct 2016 15:14:51 +0000 Subject: Purge another direct access to bytes field. --- generic/tclUtil.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 57604f8..b2749c3 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -1976,7 +1976,7 @@ Tcl_ConcatObj( resPtr = NULL; for (i = 0; i < objc; i++) { objPtr = objv[i]; - if (objPtr->bytes && objPtr->length == 0) { + if (!TclListObjIsCanonical(objPtr)) { continue; } if (resPtr) { -- cgit v0.12 From aec96db0167170b47c7f0dd132fd530354aa4ac7 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 12 Oct 2016 16:58:20 +0000 Subject: Reduce direct use of the tclEmptyStringRep. --- generic/tclPathObj.c | 3 +-- generic/tclUtil.c | 6 +++--- unix/tclUnixSock.c | 15 +++++++++------ 3 files changed, 13 insertions(+), 11 deletions(-) diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index ce371bd..fcf4dee 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -2608,8 +2608,7 @@ UpdateStringOfFsPath( pathPtr->bytes = TclGetStringFromObj(copy, &cwdLen); pathPtr->length = cwdLen; - copy->bytes = tclEmptyStringRep; - copy->length = 0; + TclInitStringRep(copy, NULL, 0); TclDecrRefCount(copy); } diff --git a/generic/tclUtil.c b/generic/tclUtil.c index b2749c3..c726174 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -1383,9 +1383,9 @@ TclConvertElement( */ if ((src == NULL) || (length == 0) || (*src == '\0' && length == -1)) { - src = tclEmptyStringRep; - length = 0; - conversion = CONVERT_BRACE; + p[0] = '{'; + p[1] = '}'; + return 2; } /* diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c index 5d11a28..44825fc 100644 --- a/unix/tclUnixSock.c +++ b/unix/tclUnixSock.c @@ -239,9 +239,6 @@ InitializeHostName( native = u.nodename; } } - if (native == NULL) { - native = tclEmptyStringRep; - } #else /* !NO_UNAME */ /* * Uname doesn't exist; try gethostname instead. @@ -270,9 +267,15 @@ InitializeHostName( #endif /* NO_UNAME */ *encodingPtr = Tcl_GetEncoding(NULL, NULL); - *lengthPtr = strlen(native); - *valuePtr = ckalloc((*lengthPtr) + 1); - memcpy(*valuePtr, native, (size_t)(*lengthPtr)+1); + if (native) { + *lengthPtr = strlen(native); + *valuePtr = ckalloc((*lengthPtr) + 1); + memcpy(*valuePtr, native, (size_t)(*lengthPtr)+1); + } else { + *lengthPtr = 0; + *valuePtr = ckalloc(1); + *valuePtr[0] = '\0'; + } } /* -- cgit v0.12 From 9fde0d3e5ad6558c526c51a8dc07fae6835cf30d Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 12 Oct 2016 17:31:48 +0000 Subject: Correct improper NULL return from initializing Tcl_InitStringRep(o, b, 0). Go ahead and return pointer to space where 0 bytes can be written. --- generic/tclObj.c | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/generic/tclObj.c b/generic/tclObj.c index 387f92b..412ecfc 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -1766,8 +1766,7 @@ Tcl_InitStringRep( objPtr->length = (int) numBytes; } } else { - objPtr->bytes = tclEmptyStringRep; - return NULL; + TclInitStringRep(objPtr, NULL, 0); } } else { /* objPtr->bytes != NULL bytes == NULL - Truncate */ -- cgit v0.12 From b1dc2099c73d4588f26bf86db45046014d647a12 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 12 Sep 2017 13:22:46 +0000 Subject: When we invalidate the string rep of a dict, that's a sign we need to free all the intreps of that dict as well. --- generic/tclDictObj.c | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index f4e15a6..b312fe1 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -909,7 +909,11 @@ InvalidateDictChain( assert( dict != NULL); do { + dict->refCount++; TclInvalidateStringRep(dictObj); + Tcl_FreeIntRep(dictObj); + DictSetIntRep(dictObj, dict); + dict->epoch++; dictObj = dict->chain; if (dictObj == NULL) { -- cgit v0.12 From bbcc51539b6cbb04bdee6c87c3f321d0f47d583b Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 12 Sep 2017 13:23:40 +0000 Subject: Revised dict value means we much invalidate existing intreps. --- generic/tclDictObj.c | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index b312fe1..d0ef59d 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -911,7 +911,7 @@ InvalidateDictChain( do { dict->refCount++; TclInvalidateStringRep(dictObj); - Tcl_FreeIntRep(dictObj); + TclFreeIntRep(dictObj); DictSetIntRep(dictObj, dict); dict->epoch++; @@ -965,6 +965,9 @@ Tcl_DictObjPut( TclInvalidateStringRep(dictPtr); hPtr = CreateChainEntry(dict, keyPtr, &isNew); + dict->refCount++; + TclFreeIntRep(dictPtr) + DictSetIntRep(dictPtr, dict); Tcl_IncrRefCount(valuePtr); if (!isNew) { Tcl_Obj *oldValuePtr = Tcl_GetHashValue(hPtr); -- cgit v0.12 From ed8604f566febdc366bae97f8d431a20612b3bfb Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 12 Sep 2017 15:18:46 +0000 Subject: Make sure ListObjAppendElement invalidates outdated intreps. --- generic/tclListObj.c | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/generic/tclListObj.c b/generic/tclListObj.c index c33b95e..fc253cc 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -711,6 +711,10 @@ Tcl_ListObjAppendElement( listRepPtr = newPtr; } ListResetIntRep(listPtr, listRepPtr); + listRepPtr->refCount++; + TclFreeIntRep(listPtr); + ListSetIntRep(listPtr, listRepPtr); + listRepPtr->refCount--; /* * Add objPtr to the end of listPtr's array of element pointers. Increment -- cgit v0.12 From de6b083f580fde9bac4b7498524a30b87581fabb Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 12 Sep 2017 15:44:00 +0000 Subject: Make sure ListObjReplace invalidates outdated intreps. --- generic/tclListObj.c | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/generic/tclListObj.c b/generic/tclListObj.c index fc253cc..f60329d 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -1127,10 +1127,15 @@ Tcl_ListObjReplace( listRepPtr->elemCount = numRequired; /* - * Invalidate and free any old string representation since it no longer - * reflects the list's internal representation. + * Invalidate and free any old representations that may not agree + * with the revised list's internal representation. */ + listRepPtr->refCount++; + TclFreeIntRep(listPtr); + ListSetIntRep(listPtr, listRepPtr); + listRepPtr->refCount--; + TclInvalidateStringRep(listPtr); return TCL_OK; } -- cgit v0.12 From 41765c8938c367e0824c280bbfe292bec64d52e1 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 12 Sep 2017 17:01:55 +0000 Subject: Rework [lset] internals to be sure outdated intreps get purged. --- generic/tclListObj.c | 39 ++++++++++++++++++++++++++++++--------- 1 file changed, 30 insertions(+), 9 deletions(-) diff --git a/generic/tclListObj.c b/generic/tclListObj.c index f60329d..c6d8d0e 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -1594,23 +1594,32 @@ TclLsetFlat( while (chainPtr) { Tcl_Obj *objPtr = chainPtr; + List *listRepPtr; + /* + * Clear away our intrep surgery mess. + */ + + irPtr = Tcl_FetchIntRep(objPtr, &tclListType); + listRepPtr = irPtr->twoPtrValue.ptr1; + chainPtr = irPtr->twoPtrValue.ptr2; + if (result == TCL_OK) { + /* * We're going to store valuePtr, so spoil string reps of all * containing lists. */ + listRepPtr->refCount++; + TclFreeIntRep(objPtr); + ListSetIntRep(objPtr, listRepPtr); + listRepPtr->refCount--; + TclInvalidateStringRep(objPtr); + } else { + irPtr->twoPtrValue.ptr2 = NULL; } - - /* - * Clear away our intrep surgery mess. - */ - - irPtr = Tcl_FetchIntRep(objPtr, &tclListType); - chainPtr = irPtr->twoPtrValue.ptr2; - irPtr->twoPtrValue.ptr2 = NULL; } if (result != TCL_OK) { @@ -1637,8 +1646,8 @@ TclLsetFlat( Tcl_ListObjAppendElement(NULL, subListPtr, valuePtr); } else { TclListObjSetElement(NULL, subListPtr, index, valuePtr); + TclInvalidateStringRep(subListPtr); } - TclInvalidateStringRep(subListPtr); Tcl_IncrRefCount(retValuePtr); return retValuePtr; } @@ -1781,6 +1790,18 @@ TclListObjSetElement( elemPtrs[index] = valuePtr; + /* + * Invalidate outdated intreps. + */ + + ListGetIntRep(listPtr, listRepPtr); + listRepPtr->refCount++; + TclFreeIntRep(listPtr); + ListSetIntRep(listPtr, listRepPtr); + listRepPtr->refCount--; + + TclInvalidateStringRep(listPtr); + return TCL_OK; } -- cgit v0.12 From 2af8b0203eae756de9f337054ead9cca1c317024 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 22 Sep 2017 13:32:31 +0000 Subject: Partial conversion of the "path" Tcl_ObjType to TIP 445 contributed by Cyan Ogilvie. This reworking also eliminates circular references in the "path" values. Test suite indicates the change works. Don't know what, if anything, was lost compared to the original Darley design. --- generic/tclPathObj.c | 194 +++++++++++++++++---------------------------------- 1 file changed, 64 insertions(+), 130 deletions(-) diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index 4e10087..9b2e67d 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -51,19 +51,14 @@ static const Tcl_ObjType fsPathType = { * represent relative or absolute paths, and has certain optimisations when * used to represent paths which are already normalized and absolute. * - * Note that both 'translatedPathPtr' and 'normPathPtr' can be a circular - * reference to the container Tcl_Obj of this FsPath. - * * There are two cases, with the first being the most common: * * (i) flags == 0, => Ordinary path. * - * translatedPathPtr contains the translated path (which may be a circular - * reference to the object itself). If it is NULL then the path is pure - * normalized (and the normPathPtr will be a circular reference). cwdPtr is - * null for an absolute path, and non-null for a relative path (unless the cwd - * has never been set, in which case the cwdPtr may also be null for a - * relative path). + * translatedPathPtr contains the translated path. If it is NULL then the path + * is pure normalized. cwdPtr is null for an absolute path, and non-null for a + * relative path (unless the cwd has never been set, in which case the cwdPtr + * may also be null for a relative path). * * (ii) flags != 0, => Special path, see TclNewFSPathObj * @@ -79,11 +74,7 @@ typedef struct FsPath { * Tcl_Obj's string rep is already both * translated and normalized. */ Tcl_Obj *normPathPtr; /* Normalized absolute path, without ., .. or - * ~user sequences. If the Tcl_Obj containing - * this FsPath is already normalized, this may - * be a circular reference back to the - * container. If that is NOT the case, we have - * a refCount on the object. */ + * ~user sequences. */ Tcl_Obj *cwdPtr; /* If null, path is absolute, else this points * to the cwd object used for this path. We * have a refCount on the object. */ @@ -110,9 +101,14 @@ typedef struct FsPath { * fields. */ -#define PATHOBJ(pathPtr) ((FsPath *) (pathPtr)->internalRep.twoPtrValue.ptr1) +#define PATHOBJ(pathPtr) ((FsPath *) (Tcl_FetchIntRep((pathPtr), &fsPathType)->twoPtrValue.ptr1)) #define SETPATHOBJ(pathPtr,fsPathPtr) \ - ((pathPtr)->internalRep.twoPtrValue.ptr1 = (void *) (fsPathPtr)) + do { \ + Tcl_ObjIntRep ir; \ + ir.twoPtrValue.ptr1 = (void *) (fsPathPtr); \ + ir.twoPtrValue.ptr2 = NULL; \ + Tcl_StoreIntRep((pathPtr), &fsPathType, &ir); \ + } while (0) #define PATHFLAGS(pathPtr) (PATHOBJ(pathPtr)->flags) /* @@ -564,7 +560,9 @@ TclPathPart( Tcl_Obj *pathPtr, /* Path to take dirname of */ Tcl_PathPart portion) /* Requested portion of name */ { - if (pathPtr->typePtr == &fsPathType) { + Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(pathPtr, &fsPathType); + + if (irPtr) { FsPath *fsPathPtr = PATHOBJ(pathPtr); if (PATHFLAGS(pathPtr) != 0) { @@ -864,6 +862,7 @@ TclJoinPath( if (elements == 2) { Tcl_Obj *elt = objv[0]; + Tcl_ObjIntRep *eltIr = Tcl_FetchIntRep(elt, &fsPathType); /* * This is a special case where we can be much more efficient, where @@ -877,7 +876,7 @@ TclJoinPath( * to be an absolute path. Added a check for that elt is absolute. */ - if ((elt->typePtr == &fsPathType) + if ((eltIr) && !((elt->bytes != NULL) && (elt->bytes[0] == '\0')) && TclGetPathType(elt, NULL, NULL, NULL) == TCL_PATH_ABSOLUTE) { Tcl_Obj *tailObj = objv[1]; @@ -1154,6 +1153,8 @@ Tcl_FSConvertToPathType( Tcl_Obj *pathPtr) /* Object to convert to a valid, current path * type. */ { + Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(pathPtr, &fsPathType); + /* * While it is bad practice to examine an object's type directly, this is * actually the best thing to do here. The reason is that if we are @@ -1164,7 +1165,7 @@ Tcl_FSConvertToPathType( * path. */ - if (pathPtr->typePtr == &fsPathType) { + if (irPtr) { if (TclFSEpochOk(PATHOBJ(pathPtr)->filesystemEpoch)) { return TCL_OK; } @@ -1172,7 +1173,7 @@ Tcl_FSConvertToPathType( if (pathPtr->bytes == NULL) { UpdateStringOfFsPath(pathPtr); } - FreeFsPathInternalRep(pathPtr); + Tcl_StoreIntRep(pathPtr, &fsPathType, NULL); } return SetFsPathFromAny(interp, pathPtr); @@ -1328,7 +1329,6 @@ TclNewFSPathObj( SETPATHOBJ(pathPtr, fsPathPtr); PATHFLAGS(pathPtr) = TCLPATH_APPENDED; - pathPtr->typePtr = &fsPathType; pathPtr->bytes = NULL; pathPtr->length = 0; @@ -1430,8 +1430,9 @@ TclFSMakePathRelative( { int cwdLen, len; const char *tempStr; + Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(pathPtr, &fsPathType); - if (pathPtr->typePtr == &fsPathType) { + if (irPtr) { FsPath *fsPathPtr = PATHOBJ(pathPtr); if (PATHFLAGS(pathPtr) != 0 && fsPathPtr->cwdPtr == cwdPtr) { @@ -1498,31 +1499,12 @@ MakePathFromNormalized( Tcl_Obj *pathPtr) /* The object to convert. */ { FsPath *fsPathPtr; + Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(pathPtr, &fsPathType); - if (pathPtr->typePtr == &fsPathType) { + if (irPtr) { return TCL_OK; } - /* - * Free old representation - */ - - if (pathPtr->typePtr != NULL) { - if (pathPtr->bytes == NULL) { - if (pathPtr->typePtr->updateStringProc == NULL) { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "can't find object string representation", -1)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH", "WTF", - NULL); - } - return TCL_ERROR; - } - pathPtr->typePtr->updateStringProc(pathPtr); - } - TclFreeIntRep(pathPtr); - } - fsPathPtr = ckalloc(sizeof(FsPath)); /* @@ -1531,11 +1513,7 @@ MakePathFromNormalized( fsPathPtr->translatedPathPtr = NULL; - /* - * Circular reference by design. - */ - - fsPathPtr->normPathPtr = pathPtr; + Tcl_IncrRefCount(fsPathPtr->normPathPtr = Tcl_DuplicateObj(pathPtr)); fsPathPtr->cwdPtr = NULL; fsPathPtr->nativePathPtr = NULL; fsPathPtr->fsPtr = NULL; @@ -1544,7 +1522,6 @@ MakePathFromNormalized( SETPATHOBJ(pathPtr, fsPathPtr); PATHFLAGS(pathPtr) = 0; - pathPtr->typePtr = &fsPathType; return TCL_OK; } @@ -1595,25 +1572,12 @@ Tcl_FSNewNativePath( * safe. */ - if (pathPtr->typePtr != NULL) { - if (pathPtr->bytes == NULL) { - if (pathPtr->typePtr->updateStringProc == NULL) { - return NULL; - } - pathPtr->typePtr->updateStringProc(pathPtr); - } - TclFreeIntRep(pathPtr); - } - + Tcl_StoreIntRep(pathPtr, &fsPathType, NULL); fsPathPtr = ckalloc(sizeof(FsPath)); fsPathPtr->translatedPathPtr = NULL; - /* - * Circular reference, by design. - */ - - fsPathPtr->normPathPtr = pathPtr; + Tcl_IncrRefCount(fsPathPtr->normPathPtr = Tcl_DuplicateObj(pathPtr)); fsPathPtr->cwdPtr = NULL; fsPathPtr->nativePathPtr = clientData; fsPathPtr->fsPtr = fromFilesystem; @@ -1621,7 +1585,6 @@ Tcl_FSNewNativePath( SETPATHOBJ(pathPtr, fsPathPtr); PATHFLAGS(pathPtr) = 0; - pathPtr->typePtr = &fsPathType; return pathPtr; } @@ -1668,20 +1631,22 @@ Tcl_FSGetTranslatedPath( Tcl_Obj *translatedCwdPtr = Tcl_FSGetTranslatedPath(interp, srcFsPathPtr->cwdPtr); + Tcl_ObjIntRep *translatedCwdIrPtr; + if (translatedCwdPtr == NULL) { return NULL; } retObj = Tcl_FSJoinToPath(translatedCwdPtr, 1, &srcFsPathPtr->normPathPtr); - srcFsPathPtr->translatedPathPtr = retObj; - if (translatedCwdPtr->typePtr == &fsPathType) { + Tcl_IncrRefCount(srcFsPathPtr->translatedPathPtr = retObj); + translatedCwdIrPtr = Tcl_FetchIntRep(translatedCwdPtr, &fsPathType); + if (translatedCwdIrPtr) { srcFsPathPtr->filesystemEpoch = PATHOBJ(translatedCwdPtr)->filesystemEpoch; } else { srcFsPathPtr->filesystemEpoch = 0; } - Tcl_IncrRefCount(retObj); Tcl_DecrRefCount(translatedCwdPtr); } else { /* @@ -1864,6 +1829,7 @@ Tcl_FSGetNormalizedPath( /* * That's our reference to copy used. */ + copy = NULL; TclDecrRefCount(dir); TclDecrRefCount(origDir); @@ -1876,7 +1842,7 @@ Tcl_FSGetNormalizedPath( /* * That's our reference to copy used. */ - + copy = NULL; TclDecrRefCount(dir); } PATHFLAGS(pathPtr) = 0; @@ -1891,7 +1857,7 @@ Tcl_FSGetNormalizedPath( if (pathPtr->bytes == NULL) { UpdateStringOfFsPath(pathPtr); } - FreeFsPathInternalRep(pathPtr); + Tcl_StoreIntRep(pathPtr, &fsPathType, NULL); if (SetFsPathFromAny(interp, pathPtr) != TCL_OK) { return NULL; } @@ -1917,7 +1883,6 @@ Tcl_FSGetNormalizedPath( } if (fsPathPtr->normPathPtr == NULL) { Tcl_Obj *useThisCwd = NULL; - int pureNormalized = 1; /* * Since normPathPtr is NULL, but this is a valid path object, we know @@ -1967,7 +1932,6 @@ Tcl_FSGetNormalizedPath( return NULL; } - pureNormalized = 0; Tcl_DecrRefCount(absolutePath); absolutePath = Tcl_FSJoinToPath(useThisCwd, 1, &absolutePath); Tcl_IncrRefCount(absolutePath); @@ -1987,7 +1951,6 @@ Tcl_FSGetNormalizedPath( if (absolutePath == NULL) { return NULL; } - pureNormalized = 0; #endif /* _WIN32 */ } } @@ -1996,35 +1959,12 @@ Tcl_FSGetNormalizedPath( * Already has refCount incremented. */ + if (fsPathPtr->normPathPtr) { + Tcl_DecrRefCount(fsPathPtr->normPathPtr); + } fsPathPtr->normPathPtr = TclFSNormalizeAbsolutePath(interp, absolutePath); - /* - * Check if path is pure normalized (this can only be the case if it - * is an absolute path). - */ - - if (pureNormalized) { - int normPathLen, pathLen; - const char *normPath; - - path = TclGetStringFromObj(pathPtr, &pathLen); - normPath = TclGetStringFromObj(fsPathPtr->normPathPtr, &normPathLen); - if ((pathLen == normPathLen) && !memcmp(path, normPath, pathLen)) { - /* - * The path was already normalized. Get rid of the duplicate. - */ - - TclDecrRefCount(fsPathPtr->normPathPtr); - - /* - * We do *not* increment the refCount for this circular - * reference. - */ - - fsPathPtr->normPathPtr = pathPtr; - } - } if (useThisCwd != NULL) { /* * We just need to free an object we allocated above for relative @@ -2170,8 +2110,9 @@ TclFSEnsureEpochOk( const Tcl_Filesystem **fsPtrPtr) { FsPath *srcFsPathPtr; + Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(pathPtr, &fsPathType); - if (pathPtr->typePtr != &fsPathType) { + if (irPtr == NULL) { return TCL_OK; } @@ -2190,7 +2131,7 @@ TclFSEnsureEpochOk( if (pathPtr->bytes == NULL) { UpdateStringOfFsPath(pathPtr); } - FreeFsPathInternalRep(pathPtr); + Tcl_StoreIntRep(pathPtr, &fsPathType, NULL); if (SetFsPathFromAny(NULL, pathPtr) != TCL_OK) { return TCL_ERROR; } @@ -2230,12 +2171,13 @@ TclFSSetPathDetails( ClientData clientData) { FsPath *srcFsPathPtr; + Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(pathPtr, &fsPathType);; /* * Make sure pathPtr is of the correct type. */ - if (pathPtr->typePtr != &fsPathType) { + if (irPtr == NULL) { if (SetFsPathFromAny(NULL, pathPtr) != TCL_OK) { return; } @@ -2333,8 +2275,9 @@ SetFsPathFromAny( FsPath *fsPathPtr; Tcl_Obj *transPtr; char *name; + Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(pathPtr, &fsPathType); - if (pathPtr->typePtr == &fsPathType) { + if (irPtr) { return TCL_OK; } @@ -2477,8 +2420,10 @@ SetFsPathFromAny( fsPathPtr = ckalloc(sizeof(FsPath)); fsPathPtr->translatedPathPtr = transPtr; - if (transPtr != pathPtr) { + if (fsPathPtr->translatedPathPtr != NULL) { Tcl_IncrRefCount(fsPathPtr->translatedPathPtr); + } + if (transPtr != pathPtr) { /* Redo translation when $env(HOME) changes */ fsPathPtr->filesystemEpoch = TclFSEpoch(); } else { @@ -2489,14 +2434,8 @@ SetFsPathFromAny( fsPathPtr->nativePathPtr = NULL; fsPathPtr->fsPtr = NULL; - /* - * Free old representation before installing our new one. - */ - - TclFreeIntRep(pathPtr); SETPATHOBJ(pathPtr, fsPathPtr); PATHFLAGS(pathPtr) = 0; - pathPtr->typePtr = &fsPathType; return TCL_OK; } @@ -2519,6 +2458,7 @@ FreeFsPathInternalRep( } if (fsPathPtr->cwdPtr != NULL) { TclDecrRefCount(fsPathPtr->cwdPtr); + fsPathPtr->cwdPtr = NULL; } if (fsPathPtr->nativePathPtr != NULL && fsPathPtr->fsPtr != NULL) { Tcl_FSFreeInternalRepProc *freeProc = @@ -2531,7 +2471,6 @@ FreeFsPathInternalRep( } ckfree(fsPathPtr); - pathPtr->typePtr = NULL; } static void @@ -2544,24 +2483,14 @@ DupFsPathInternalRep( SETPATHOBJ(copyPtr, copyFsPathPtr); - if (srcFsPathPtr->translatedPathPtr == srcPtr) { - /* Cycle in src -> make cycle in copy. */ - copyFsPathPtr->translatedPathPtr = copyPtr; - } else { - copyFsPathPtr->translatedPathPtr = srcFsPathPtr->translatedPathPtr; - if (copyFsPathPtr->translatedPathPtr != NULL) { - Tcl_IncrRefCount(copyFsPathPtr->translatedPathPtr); - } + copyFsPathPtr->translatedPathPtr = srcFsPathPtr->translatedPathPtr; + if (copyFsPathPtr->translatedPathPtr != NULL) { + Tcl_IncrRefCount(copyFsPathPtr->translatedPathPtr); } - if (srcFsPathPtr->normPathPtr == srcPtr) { - /* Cycle in src -> make cycle in copy. */ - copyFsPathPtr->normPathPtr = copyPtr; - } else { - copyFsPathPtr->normPathPtr = srcFsPathPtr->normPathPtr; - if (copyFsPathPtr->normPathPtr != NULL) { - Tcl_IncrRefCount(copyFsPathPtr->normPathPtr); - } + copyFsPathPtr->normPathPtr = srcFsPathPtr->normPathPtr; + if (copyFsPathPtr->normPathPtr != NULL) { + Tcl_IncrRefCount(copyFsPathPtr->normPathPtr); } copyFsPathPtr->cwdPtr = srcFsPathPtr->cwdPtr; @@ -2587,8 +2516,6 @@ DupFsPathInternalRep( } copyFsPathPtr->fsPtr = srcFsPathPtr->fsPtr; copyFsPathPtr->filesystemEpoch = srcFsPathPtr->filesystemEpoch; - - copyPtr->typePtr = &fsPathType; } /* @@ -2620,7 +2547,12 @@ UpdateStringOfFsPath( } copy = AppendPath(fsPathPtr->cwdPtr, fsPathPtr->normPathPtr); + if (Tcl_IsShared(copy)) { + copy = Tcl_DuplicateObj(copy); + } + Tcl_IncrRefCount(copy); + /* Steal copy's string rep */ pathPtr->bytes = TclGetStringFromObj(copy, &cwdLen); pathPtr->length = cwdLen; TclInitStringRep(copy, NULL, 0); @@ -2653,6 +2585,8 @@ TclNativePathInFilesystem( Tcl_Obj *pathPtr, ClientData *clientDataPtr) { + Tcl_ObjIntRep *irPtr = Tcl_FetchIntRep(pathPtr, &fsPathType); + /* * A special case is required to handle the empty path "". This is a valid * path (i.e. the user should be able to do 'file exists ""' without @@ -2660,7 +2594,7 @@ TclNativePathInFilesystem( * semantics of Tcl (at present anyway), so we have to abide by them here. */ - if (pathPtr->typePtr == &fsPathType) { + if (irPtr) { if (pathPtr->bytes != NULL && pathPtr->bytes[0] == '\0') { /* * We reject the empty path "". -- cgit v0.12 From de970528d7f4dd9acb90d3ddfabdc79849808923 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 22 Sep 2017 14:11:45 +0000 Subject: More TIP 445 conversion of the "path" Tcl_ObjType. --- generic/tclPathObj.c | 40 +++++----------------------------------- 1 file changed, 5 insertions(+), 35 deletions(-) diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index 9b2e67d..be3d57c 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -1170,34 +1170,11 @@ Tcl_FSConvertToPathType( return TCL_OK; } - if (pathPtr->bytes == NULL) { - UpdateStringOfFsPath(pathPtr); - } + TclGetString(pathPtr); Tcl_StoreIntRep(pathPtr, &fsPathType, NULL); } return SetFsPathFromAny(interp, pathPtr); - - /* - * We used to have more complex code here: - * - * FsPath *fsPathPtr = PATHOBJ(pathPtr); - * if (fsPathPtr->cwdPtr == NULL || PATHFLAGS(pathPtr) != 0) { - * return TCL_OK; - * } else { - * if (TclFSCwdPointerEquals(&fsPathPtr->cwdPtr)) { - * return TCL_OK; - * } else { - * if (pathPtr->bytes == NULL) { - * UpdateStringOfFsPath(pathPtr); - * } - * FreeFsPathInternalRep(pathPtr); - * return Tcl_ConvertToType(interp, pathPtr, &fsPathType); - * } - * } - * - * But we no longer believe this is necessary. - */ } /* @@ -1329,8 +1306,7 @@ TclNewFSPathObj( SETPATHOBJ(pathPtr, fsPathPtr); PATHFLAGS(pathPtr) = TCLPATH_APPENDED; - pathPtr->bytes = NULL; - pathPtr->length = 0; + TclInvalidateStringRep(pathPtr); /* * Look for path components made up of only "." @@ -1756,9 +1732,7 @@ Tcl_FSGetNormalizedPath( return NULL; } /* TODO: Figure out why this is needed. */ - if (pathPtr->bytes == NULL) { - UpdateStringOfFsPath(pathPtr); - } + TclGetString(pathPtr); TclGetStringFromObj(fsPathPtr->normPathPtr, &tailLen); if (tailLen) { @@ -1854,9 +1828,7 @@ Tcl_FSGetNormalizedPath( if (fsPathPtr->cwdPtr != NULL) { if (!TclFSCwdPointerEquals(&fsPathPtr->cwdPtr)) { - if (pathPtr->bytes == NULL) { - UpdateStringOfFsPath(pathPtr); - } + TclGetString(pathPtr); Tcl_StoreIntRep(pathPtr, &fsPathType, NULL); if (SetFsPathFromAny(interp, pathPtr) != TCL_OK) { return NULL; @@ -2128,9 +2100,7 @@ TclFSEnsureEpochOk( * We have to discard the stale representation and recalculate it. */ - if (pathPtr->bytes == NULL) { - UpdateStringOfFsPath(pathPtr); - } + TclGetString(pathPtr); Tcl_StoreIntRep(pathPtr, &fsPathType, NULL); if (SetFsPathFromAny(NULL, pathPtr) != TCL_OK) { return TCL_ERROR; -- cgit v0.12 From 2815504547bdf726de6bea3aae6bbee6896743ad Mon Sep 17 00:00:00 2001 From: hypnotoad Date: Tue, 13 Feb 2018 18:55:31 +0000 Subject: Implemetation of tip 501. Note: The build fails with: bad stack depth computations: is 0, should be 1 Abort trap: 6 When "string is dict" is called --- generic/tclCmdMZ.c | 11 +++++++-- generic/tclCompCmdsSZ.c | 19 ++++++++++++--- tests/string.test | 61 +++++++++++++++++++++++++++++++++++++++++++++++-- 3 files changed, 84 insertions(+), 7 deletions(-) diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index d63a985..5f19d28 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -1468,7 +1468,7 @@ StringIsCmd( static const char *const isClasses[] = { "alnum", "alpha", "ascii", "control", - "boolean", "digit", "double", "entier", + "boolean", "dict", "digit", "double", "entier", "false", "graph", "integer", "list", "lower", "print", "punct", "space", "true", "upper", "wideinteger", "wordchar", @@ -1476,7 +1476,7 @@ StringIsCmd( }; enum isClasses { STR_IS_ALNUM, STR_IS_ALPHA, STR_IS_ASCII, STR_IS_CONTROL, - STR_IS_BOOL, STR_IS_DIGIT, STR_IS_DOUBLE, STR_IS_ENTIER, + STR_IS_BOOL, STR_IS_DICT, STR_IS_DIGIT, STR_IS_DOUBLE, STR_IS_ENTIER, STR_IS_FALSE, STR_IS_GRAPH, STR_IS_INT, STR_IS_LIST, STR_IS_LOWER, STR_IS_PRINT, STR_IS_PUNCT, STR_IS_SPACE, STR_IS_TRUE, STR_IS_UPPER, STR_IS_WIDE, STR_IS_WORD, @@ -1567,6 +1567,13 @@ StringIsCmd( case STR_IS_CONTROL: chcomp = Tcl_UniCharIsControl; break; + case STR_IS_DICT: { + int dresult, dsize; + dresult = Tcl_DictObjSize(interp, objPtr, &dsize); + Tcl_ResetResult(interp); + result = (dresult==TCL_OK) ? 1 : 0; + break; + } case STR_IS_DIGIT: chcomp = Tcl_UniCharIsDigit; break; diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 101edbd..001202e 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -513,7 +513,7 @@ TclCompileStringIsCmd( Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); static const char *const isClasses[] = { "alnum", "alpha", "ascii", "control", - "boolean", "digit", "double", "entier", + "boolean", "dict", "digit", "double", "entier", "false", "graph", "integer", "list", "lower", "print", "punct", "space", "true", "upper", "wideinteger", "wordchar", @@ -521,7 +521,7 @@ TclCompileStringIsCmd( }; enum isClasses { STR_IS_ALNUM, STR_IS_ALPHA, STR_IS_ASCII, STR_IS_CONTROL, - STR_IS_BOOL, STR_IS_DIGIT, STR_IS_DOUBLE, STR_IS_ENTIER, + STR_IS_BOOL, STR_IS_DICT, STR_IS_DIGIT, STR_IS_DOUBLE, STR_IS_ENTIER, STR_IS_FALSE, STR_IS_GRAPH, STR_IS_INT, STR_IS_LIST, STR_IS_LOWER, STR_IS_PRINT, STR_IS_PUNCT, STR_IS_SPACE, STR_IS_TRUE, STR_IS_UPPER, STR_IS_WIDE, STR_IS_WORD, @@ -758,7 +758,20 @@ TclCompileStringIsCmd( } FIXJUMP1( end); return TCL_OK; - + case STR_IS_DICT: + range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); + OP4( BEGIN_CATCH4, range); + ExceptionRangeStarts(envPtr, range); + OP( DUP); + OP( DICT_VERIFY); + OP( POP); + ExceptionRangeEnds(envPtr, range); + ExceptionRangeTarget(envPtr, range, catchOffset); + OP( POP); + OP( PUSH_RETURN_CODE); + OP( END_CATCH); + OP( LNOT); + return TCL_OK; case STR_IS_LIST: range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); OP4( BEGIN_CATCH4, range); diff --git a/tests/string.test b/tests/string.test index 53f1cfb..51bf073 100644 --- a/tests/string.test +++ b/tests/string.test @@ -316,10 +316,10 @@ test string-6.4 {string is, too many args} { } {1 {wrong # args: should be "string is class ?-strict? ?-failindex var? str"}} test string-6.5 {string is, class check} { list [catch {string is bogus str} msg] $msg -} {1 {bad class "bogus": must be alnum, alpha, ascii, control, boolean, digit, double, entier, false, graph, integer, list, lower, print, punct, space, true, upper, wideinteger, wordchar, or xdigit}} +} {1 {bad class "bogus": must be alnum, alpha, ascii, control, boolean, dict, digit, double, entier, false, graph, integer, list, lower, print, punct, space, true, upper, wideinteger, wordchar, or xdigit}} test string-6.6 {string is, ambiguous class} { list [catch {string is al str} msg] $msg -} {1 {ambiguous class "al": must be alnum, alpha, ascii, control, boolean, digit, double, entier, false, graph, integer, list, lower, print, punct, space, true, upper, wideinteger, wordchar, or xdigit}} +} {1 {ambiguous class "al": must be alnum, alpha, ascii, control, boolean, dict, digit, double, entier, false, graph, integer, list, lower, print, punct, space, true, upper, wideinteger, wordchar, or xdigit}} test string-6.7 {string is alpha, all ok} { string is alpha -strict -failindex var abc } 1 @@ -2000,6 +2000,63 @@ test string-29.4 {string cat, many args} { } {0 0} +test string-30.1 {string is dict} { + string is dict {a b c} +} 1 +test string-30.2 {string is dict} { + string is dict "a \{b c" +} 0 +test string-30.3 {string is dict} { + string is dict {a {b c}d e} +} 0 +test string-30.4 {string is dict} { + string is dict {} +} 1 +test string-30.5 {string is dict} { + string is dict -strict {a b c} +} 1 +test string-30.6 {string is dict} { + string is dict -strict "a \{b c" +} 0 +test string-30.7 {string is dict} { + string is dict -strict {a {b c}d e} +} 0 +test string-30.8 {string is dict} { + string is dict -strict {} +} 1 +test string-30.9 {string is dict} { + set x {} + list [string is dict -failindex x {a b c}] $x +} {1 {}} +test string-30.10 {string is dict} { + set x {} + list [string is dict -failindex x "a \{b c"] $x +} {0 2} +test string-30.11 {string is dict} { + set x {} + list [string is dict -failindex x {a b {b c}d e}] $x +} {0 4} +test string-30.12 {string is dict} { + set x {} + list [string is dict -failindex x {}] $x +} {1 {}} +test string-30.13 {string is dict} { + set x {} + list [string is dict -failindex x { {b c}d e}] $x +} {0 2} +test string-30.14 {string is dict} { + set x {} + list [string is dict -failindex x "\uabcd {b c}d e"] $x +} {0 2} +test string-30.15 {string is dict, valid dict} { + string is dict {a b c d e f} +} 1 +test string-30.16 {string is dict, invalid dict} { + string is dict a +} 0 +test string-30.17 {string is dict, valid dict packed in invalid dict} { + string is dict {{a b c d e f g h}} +} 0 # cleanup rename MemStress {} -- cgit v0.12 From d49ccd64f2f154eedcab6322a4b9c45f7e63716e Mon Sep 17 00:00:00 2001 From: hypnotoad Date: Tue, 13 Feb 2018 19:10:25 +0000 Subject: Ok.. that was all it needed --- generic/tclCompCmdsSZ.c | 1 - 1 file changed, 1 deletion(-) diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 001202e..b5676cb 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -764,7 +764,6 @@ TclCompileStringIsCmd( ExceptionRangeStarts(envPtr, range); OP( DUP); OP( DICT_VERIFY); - OP( POP); ExceptionRangeEnds(envPtr, range); ExceptionRangeTarget(envPtr, range, catchOffset); OP( POP); -- cgit v0.12 From c5a85dbfdc7dce9328b7f5fffb0bae519f68cf9f Mon Sep 17 00:00:00 2001 From: hypnotoad Date: Tue, 13 Feb 2018 19:22:31 +0000 Subject: Correcting the string tests --- tests/string.test | 30 +++++++++++++++++++++++------- 1 file changed, 23 insertions(+), 7 deletions(-) diff --git a/tests/string.test b/tests/string.test index 51bf073..a4797fa 100644 --- a/tests/string.test +++ b/tests/string.test @@ -2001,8 +2001,12 @@ test string-29.4 {string cat, many args} { test string-30.1 {string is dict} { - string is dict {a b c} + string is dict {a b c d} } 1 +test string-30.1a {string is dict} { + string is dict {a b c} +} 0 + test string-30.2 {string is dict} { string is dict "a \{b c" } 0 @@ -2013,8 +2017,12 @@ test string-30.4 {string is dict} { string is dict {} } 1 test string-30.5 {string is dict} { - string is dict -strict {a b c} + string is dict -strict {a b c d} } 1 +test string-30.5a {string is dict} { + string is dict -strict {a b c} +} 0 + test string-30.6 {string is dict} { string is dict -strict "a \{b c" } 0 @@ -2026,16 +2034,24 @@ test string-30.8 {string is dict} { } 1 test string-30.9 {string is dict} { set x {} - list [string is dict -failindex x {a b c}] $x + list [string is dict -failindex x {a b c d}] $x } {1 {}} +test string-30.9a {string is dict} { + set x {} + list [string is dict -failindex x {a b c}] $x +} {0 0} test string-30.10 {string is dict} { set x {} + list [string is dict -failindex x "a \{b c d"] $x +} {0 0} +test string-30.10a {string is dict} { + set x {} list [string is dict -failindex x "a \{b c"] $x -} {0 2} +} {0 0} test string-30.11 {string is dict} { set x {} list [string is dict -failindex x {a b {b c}d e}] $x -} {0 4} +} {0 0} test string-30.12 {string is dict} { set x {} list [string is dict -failindex x {}] $x @@ -2043,11 +2059,11 @@ test string-30.12 {string is dict} { test string-30.13 {string is dict} { set x {} list [string is dict -failindex x { {b c}d e}] $x -} {0 2} +} {0 0} test string-30.14 {string is dict} { set x {} list [string is dict -failindex x "\uabcd {b c}d e"] $x -} {0 2} +} {0 0} test string-30.15 {string is dict, valid dict} { string is dict {a b c d e f} } 1 -- cgit v0.12 From 9ff5b7077a286a44e200859c71d641d9ea3bd60d Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 25 Apr 2018 11:09:53 +0000 Subject: Plug memory leak handling circular path values. --- generic/tclPathObj.c | 14 ++++++-------- 1 file changed, 6 insertions(+), 8 deletions(-) diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index e9d2fcb..c072fe0 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -2388,16 +2388,14 @@ SetFsPathFromAny( fsPathPtr = ckalloc(sizeof(FsPath)); - fsPathPtr->translatedPathPtr = transPtr; - if (fsPathPtr->translatedPathPtr != NULL) { - Tcl_IncrRefCount(fsPathPtr->translatedPathPtr); - } - if (transPtr != pathPtr) { - /* Redo translation when $env(HOME) changes */ - fsPathPtr->filesystemEpoch = TclFSEpoch(); + if (transPtr == pathPtr) { + transPtr = Tcl_DuplicateObj(pathPtr); + fsPathPtr->filesystemEpoch = 0; } else { - fsPathPtr->filesystemEpoch = 0; + fsPathPtr->filesystemEpoch = TclFSEpoch(); } + Tcl_IncrRefCount(transPtr); + fsPathPtr->translatedPathPtr = transPtr; fsPathPtr->normPathPtr = NULL; fsPathPtr->cwdPtr = NULL; fsPathPtr->nativePathPtr = NULL; -- cgit v0.12 From 77bd578d9f6fd5b168738b2a88a37d140a1302ec Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 25 Jun 2018 20:41:56 +0000 Subject: TIP #512 implementation --- generic/tcl.decls | 6 +++--- generic/tclDecls.h | 6 +++--- generic/tclStubInit.c | 4 ++++ tools/genStubs.tcl | 12 ++++++++++++ 4 files changed, 22 insertions(+), 6 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index da551bb..3734339 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -513,7 +513,7 @@ declare 142 { declare 143 { void Tcl_Finalize(void) } -declare 144 { +declare 144 {nostub {Don't use this function in a stub-enabled extension}} { void Tcl_FindExecutable(const char *argv0) } declare 145 { @@ -812,7 +812,7 @@ declare 228 { declare 229 { void Tcl_SetMaxBlockTime(const Tcl_Time *timePtr) } -declare 230 { +declare 230 {nostub {Don't use this function in a stub-enabled extension}} { void Tcl_SetPanicProc(TCL_NORETURN1 Tcl_PanicProc *panicProc) } declare 231 { @@ -1868,7 +1868,7 @@ declare 518 { } # TIP#121 (exit handler) dkf for Joe Mistachkin -declare 519 { +declare 519 {nostub {Don't use this function in a stub-enabled extension}} { Tcl_ExitProc *Tcl_SetExitProc(TCL_NORETURN1 Tcl_ExitProc *proc) } diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 592d945..b96b963 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -2009,7 +2009,7 @@ typedef struct TclStubs { int (*tcl_ExprObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Obj **resultPtrPtr); /* 141 */ int (*tcl_ExprString) (Tcl_Interp *interp, const char *expr); /* 142 */ void (*tcl_Finalize) (void); /* 143 */ - void (*tcl_FindExecutable) (const char *argv0); /* 144 */ + TCL_DEPRECATED_API("Don't use this function in a stub-enabled extension") void (*tcl_FindExecutable) (const char *argv0); /* 144 */ Tcl_HashEntry * (*tcl_FirstHashEntry) (Tcl_HashTable *tablePtr, Tcl_HashSearch *searchPtr); /* 145 */ int (*tcl_Flush) (Tcl_Channel chan); /* 146 */ void (*tcl_FreeResult) (Tcl_Interp *interp); /* 147 */ @@ -2103,7 +2103,7 @@ typedef struct TclStubs { void (*tcl_SetErrno) (int err); /* 227 */ void (*tcl_SetErrorCode) (Tcl_Interp *interp, ...); /* 228 */ void (*tcl_SetMaxBlockTime) (const Tcl_Time *timePtr); /* 229 */ - void (*tcl_SetPanicProc) (TCL_NORETURN1 Tcl_PanicProc *panicProc); /* 230 */ + TCL_DEPRECATED_API("Don't use this function in a stub-enabled extension") void (*tcl_SetPanicProc) (TCL_NORETURN1 Tcl_PanicProc *panicProc); /* 230 */ int (*tcl_SetRecursionLimit) (Tcl_Interp *interp, int depth); /* 231 */ void (*tcl_SetResult) (Tcl_Interp *interp, char *result, Tcl_FreeProc *freeProc); /* 232 */ int (*tcl_SetServiceMode) (int mode); /* 233 */ @@ -2392,7 +2392,7 @@ typedef struct TclStubs { Tcl_Command (*tcl_GetCommandFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 516 */ void (*tcl_GetCommandFullName) (Tcl_Interp *interp, Tcl_Command command, Tcl_Obj *objPtr); /* 517 */ int (*tcl_FSEvalFileEx) (Tcl_Interp *interp, Tcl_Obj *fileName, const char *encodingName); /* 518 */ - Tcl_ExitProc * (*tcl_SetExitProc) (TCL_NORETURN1 Tcl_ExitProc *proc); /* 519 */ + TCL_DEPRECATED_API("Don't use this function in a stub-enabled extension") Tcl_ExitProc * (*tcl_SetExitProc) (TCL_NORETURN1 Tcl_ExitProc *proc); /* 519 */ void (*tcl_LimitAddHandler) (Tcl_Interp *interp, int type, Tcl_LimitHandlerProc *handlerProc, ClientData clientData, Tcl_LimitHandlerDeleteProc *deleteProc); /* 520 */ void (*tcl_LimitRemoveHandler) (Tcl_Interp *interp, int type, Tcl_LimitHandlerProc *handlerProc, ClientData clientData); /* 521 */ int (*tcl_LimitReady) (Tcl_Interp *interp); /* 522 */ diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 7ce0758..0548825 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -40,6 +40,7 @@ #undef Tcl_CreateHashEntry #undef Tcl_Panic #undef Tcl_FindExecutable +#undef Tcl_SetExitProc #undef Tcl_SetPanicProc #undef TclpGetPid #undef TclSockMinimumBuffers @@ -402,6 +403,9 @@ static int uniCharNcasecmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsig # define TclpGmtime 0 # define TclpLocaltime_unix 0 # define TclpGmtime_unix 0 +# define Tcl_SetExitProc 0 +# define Tcl_SetPanicProc 0 +# define Tcl_FindExecutable 0 #else /* TCL_NO_DEPRECATED */ # define Tcl_SeekOld seekOld # define Tcl_TellOld tellOld diff --git a/tools/genStubs.tcl b/tools/genStubs.tcl index 830ba2b..f2f410f 100644 --- a/tools/genStubs.tcl +++ b/tools/genStubs.tcl @@ -198,6 +198,13 @@ proc genStubs::declare {args} { || ($index > $stubs($curName,generic,lastNum))} { set stubs($curName,generic,lastNum) $index } + } elseif {([lindex $platformList 0] eq "nostub")} { + set stubs($curName,nostub,$index) [lindex $platformList 1] + set stubs($curName,generic,$index) $decl + if {![info exists stubs($curName,generic,lastNum)] \ + || ($index > $stubs($curName,generic,lastNum))} { + set stubs($curName,generic,lastNum) $index + } } else { foreach platform $platformList { if {$decl ne ""} { @@ -593,6 +600,8 @@ proc genStubs::makeSlot {name decl index} { set text " " if {[info exists stubs($name,deprecated,$index)]} { append text "TCL_DEPRECATED_API(\"$stubs($name,deprecated,$index)\") " + } elseif {[info exists stubs($name,nostub,$index)]} { + append text "TCL_DEPRECATED_API(\"$stubs($name,nostub,$index)\") " } if {$args eq ""} { append text $rtype " *" $lfname "; /* $index */\n" @@ -705,6 +714,9 @@ proc genStubs::forAllStubs {name slotProc onAll textVar if {[info exists stubs($name,deprecated,$i)]} { append text [$slotProc $name $stubs($name,generic,$i) $i] set emit 1 + } elseif {[info exists stubs($name,nostub,$i)]} { + append text [$slotProc $name $stubs($name,generic,$i) $i] + set emit 1 } elseif {[info exists stubs($name,generic,$i)]} { if {[llength $slots] > 1} { puts stderr "conflicting generic and platform entries:\ -- cgit v0.12 From c74364be4c0ab1ca34ba34f02a662708473d62a9 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 5 Oct 2018 19:37:52 +0000 Subject: Bump version numbers for 8.6.9 release. --- README | 2 +- generic/tcl.h | 8 ++------ library/init.tcl | 2 +- unix/configure | 2 +- unix/configure.in | 2 +- unix/tcl.spec | 2 +- win/configure | 2 +- win/configure.in | 2 +- 8 files changed, 9 insertions(+), 13 deletions(-) diff --git a/README b/README index adfdf97..f286244 100644 --- a/README +++ b/README @@ -1,5 +1,5 @@ README: Tcl - This is the Tcl 8.6.8 source distribution. + This is the Tcl 8.6.9 source distribution. http://sourceforge.net/projects/tcl/files/Tcl/ You can get any source release of Tcl from the URL above. diff --git a/generic/tcl.h b/generic/tcl.h index 36001ca..17ab2d3 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -42,10 +42,6 @@ extern "C" { * win/configure.in (as above) * win/tcl.m4 (not patchlevel) * README (sections 0 and 2, with and without separator) - * macosx/Tcl.pbproj/project.pbxproj (not patchlevel) 1 LOC - * macosx/Tcl.pbproj/default.pbxuser (not patchlevel) 1 LOC - * macosx/Tcl.xcode/project.pbxproj (not patchlevel) 2 LOC - * macosx/Tcl.xcode/default.pbxuser (not patchlevel) 1 LOC * macosx/Tcl-Common.xcconfig (not patchlevel) 1 LOC * win/README (not patchlevel) (sections 0 and 2) * unix/tcl.spec (1 LOC patch) @@ -55,10 +51,10 @@ extern "C" { #define TCL_MAJOR_VERSION 8 #define TCL_MINOR_VERSION 6 #define TCL_RELEASE_LEVEL TCL_FINAL_RELEASE -#define TCL_RELEASE_SERIAL 8 +#define TCL_RELEASE_SERIAL 9 #define TCL_VERSION "8.6" -#define TCL_PATCH_LEVEL "8.6.8" +#define TCL_PATCH_LEVEL "8.6.9" /* *---------------------------------------------------------------------------- diff --git a/library/init.tcl b/library/init.tcl index b3990df..8952172 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -16,7 +16,7 @@ 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.6.8 +package require -exact Tcl 8.6.9 # Compute the auto path to use in this interpreter. # The values on the path come from several locations: diff --git a/unix/configure b/unix/configure index fdf9146..53dc947 100755 --- a/unix/configure +++ b/unix/configure @@ -1335,7 +1335,7 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu TCL_VERSION=8.6 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=6 -TCL_PATCH_LEVEL=".8" +TCL_PATCH_LEVEL=".9" VERSION=${TCL_VERSION} EXTRA_INSTALL_BINARIES=${EXTRA_INSTALL_BINARIES:-"@:"} diff --git a/unix/configure.in b/unix/configure.in index bfa2ef7..52a0648 100644 --- a/unix/configure.in +++ b/unix/configure.in @@ -25,7 +25,7 @@ m4_ifdef([SC_USE_CONFIG_HEADERS], [ TCL_VERSION=8.6 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=6 -TCL_PATCH_LEVEL=".8" +TCL_PATCH_LEVEL=".9" VERSION=${TCL_VERSION} EXTRA_INSTALL_BINARIES=${EXTRA_INSTALL_BINARIES:-"@:"} diff --git a/unix/tcl.spec b/unix/tcl.spec index 09920dd..cc36790 100644 --- a/unix/tcl.spec +++ b/unix/tcl.spec @@ -4,7 +4,7 @@ Name: tcl Summary: Tcl scripting language development environment -Version: 8.6.8 +Version: 8.6.9 Release: 2 License: BSD Group: Development/Languages diff --git a/win/configure b/win/configure index 03ad68a..3024594 100755 --- a/win/configure +++ b/win/configure @@ -1311,7 +1311,7 @@ SHELL=/bin/sh TCL_VERSION=8.6 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=6 -TCL_PATCH_LEVEL=".8" +TCL_PATCH_LEVEL=".9" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION TCL_DDE_VERSION=1.4 diff --git a/win/configure.in b/win/configure.in index 82351f1..511cb39 100644 --- a/win/configure.in +++ b/win/configure.in @@ -14,7 +14,7 @@ SHELL=/bin/sh TCL_VERSION=8.6 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=6 -TCL_PATCH_LEVEL=".8" +TCL_PATCH_LEVEL=".9" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION TCL_DDE_VERSION=1.4 -- cgit v0.12 From d918760272b92d4903c0145b612bf8b353c8a51f Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 10 Oct 2018 23:04:25 +0000 Subject: Backport test fix. --- tests/macOSXFCmd.test | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/tests/macOSXFCmd.test b/tests/macOSXFCmd.test index 071f11b..132b2fe 100644 --- a/tests/macOSXFCmd.test +++ b/tests/macOSXFCmd.test @@ -151,16 +151,16 @@ test macOSXFCmd-4.1 {TclMacOSXMatchType} {macosxFileAttr notRoot} { file attributes dir.test -hidden 1 } set res [list \ - [catch {glob *.test} msg] $msg \ - [catch {glob -types FOOT *.test} msg] $msg \ - [catch {glob -types {{macintosh type FOOT}} *.test} msg] $msg \ - [catch {glob -types FOOTT *.test} msg] $msg \ - [catch {glob -types {{macintosh type FOOTT}} *.test} msg] $msg \ - [catch {glob -types {{macintosh type {}}} *.test} msg] $msg \ - [catch {glob -types {{macintosh creator FOOC}} *.test} msg] $msg \ - [catch {glob -types {{macintosh creator FOOC} {macintosh type FOOT}} *.test} msg] $msg \ - [catch {glob -types hidden *.test} msg] $msg \ - [catch {glob -types {hidden FOOT} *.test} msg] $msg \ + [catch {lsort [glob *.test]} msg] $msg \ + [catch {lsort [glob -types FOOT *.test]} msg] $msg \ + [catch {lsort [glob -types {{macintosh type FOOT}} *.test]} msg] $msg \ + [catch {lsort [glob -types FOOTT *.test]} msg] $msg \ + [catch {lsort [glob -types {{macintosh type FOOTT}} *.test]} msg] $msg \ + [catch {lsort [glob -types {{macintosh type {}}} *.test]} msg] $msg \ + [catch {lsort [glob -types {{macintosh creator FOOC}} *.test]} msg] $msg \ + [catch {lsort [glob -types {{macintosh creator FOOC} {macintosh type FOOT}} *.test]} msg] $msg \ + [catch {lsort [glob -types hidden *.test]} msg] $msg \ + [catch {lsort [glob -types {hidden FOOT} *.test]} msg] $msg \ ] cd .. file delete -force globtest -- cgit v0.12 From f4f6ef461bd3f9e635f4f433c6a732fe4e5e4903 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 11 Oct 2018 11:31:29 +0000 Subject: Update URLs. changes file WIP. --- ChangeLog | 2 +- README | 22 +++++++++++----------- changes | 18 ++++++++++++++++++ 3 files changed, 30 insertions(+), 12 deletions(-) diff --git a/ChangeLog b/ChangeLog index e2881a0..84281bc 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,6 +1,6 @@ A NOTE ON THE CHANGELOG: Starting in early 2011, Tcl source code has been under the management of -fossil, hosted at http://core.tcl.tk/tcl/ . Fossil presents a "Timeline" +fossil, hosted at https://core.tcl-lang.org/tcl/ . Fossil presents a "Timeline" view of changes made that is superior in every way to a hand edited log file. Because of this, many Tcl developers are now out of the habit of maintaining this log file. You may still find useful things in it, but the Timeline is diff --git a/README b/README index f286244..dae0dda 100644 --- a/README +++ b/README @@ -29,7 +29,7 @@ Tcl is maintained, enhanced, and distributed freely by the Tcl community. Source code development and tracking of bug reports and feature requests takes place at: - http://core.tcl.tk/ + http://core.tcl-lang.org/ Tcl/Tk release and mailing list services are hosted by SourceForge: @@ -37,7 +37,7 @@ Tcl/Tk release and mailing list services are hosted by SourceForge: with the Tcl Developer Xchange hosted at: - http://www.tcl.tk/ + http://www.tcl-lang.org/ Tcl is a freely available open source package. You can do virtually anything you like with it, such as modifying it, redistributing it, @@ -49,21 +49,21 @@ and selling it either in whole or in part. See the file Extensive documentation is available at our website. The home page for this release, including new features, is - http://www.tcl.tk/software/tcltk/8.6.html + http://www.tcl-lang.org/software/tcltk/8.6.html Detailed release notes can be found at the file distributions page by clicking on the relevant version. http://sourceforge.net/projects/tcl/files/Tcl/ Information about Tcl itself can be found at - http://www.tcl.tk/about/ + http://www.tcl-lang.org/about/ There have been many Tcl books on the market. Many are mentioned in the Wiki: - http://wiki.tcl.tk/_/ref?N=25206 + http://wiki.tcl-lang.org/_/ref?N=25206 To view the complete set of reference manual entries for Tcl 8.6 online, visit the URL: - http://www.tcl.tk/man/tcl8.6/ + http://www.tcl-lang.org/man/tcl8.6/ 2a. Unix Documentation ---------------------- @@ -101,7 +101,7 @@ There are brief notes in the unix/README, win/README, and macosx/README about compiling on these different platforms. There is additional information about building Tcl from sources at - http://www.tcl.tk/doc/howto/compile.html + http://www.tcl-lang.org/doc/howto/compile.html 4. Development tools --------------------------- @@ -127,7 +127,7 @@ see the "Support and bug fixes" section below. A Wiki-based open community site covering all aspects of Tcl/Tk is at: - http://wiki.tcl.tk/ + http://wiki.tcl-lang.org/ It is dedicated to the Tcl programming language and its extensions. A wealth of useful information can be found there. It contains code @@ -153,7 +153,7 @@ We are very interested in receiving bug reports, patches, and suggestions for improvements. We prefer that you send this information to us as tickets entered into our tracker at: - http://core.tcl.tk/tcl/reportlist + http://core.tcl-lang.org/tcl/reportlist We will log and follow-up on each bug, although we cannot promise a specific turn-around time. Enhancements may take longer and may not happen @@ -169,13 +169,13 @@ questions for which no one else is likely to know the answer. In addition, see the following Web site for links to other organizations that offer Tcl/Tk training: - http://wiki.tcl.tk/training + http://wiki.tcl-lang.org/training 9. Tracking Development ----------------------- Tcl is developed in public. To keep an eye on how Tcl is changing, see - http://core.tcl.tk/ + http://core.tcl-lang.org/ 10. Thank You ------------- diff --git a/changes b/changes index 040f360..1d5ba66 100644 --- a/changes +++ b/changes @@ -8830,3 +8830,21 @@ improvements to regexp engine from Postgres (lane,porter,fellows,seltenreich) 2017-12-19 (bug)[586e71] EvalObjv exception handling at level #0 (sebres,porter) --- Released 8.6.8, December 22, 2017 --- http://core.tcl.tk/tcl/ for details + +2018-02-11 (enhance) stop blocking conversion of object to/from class (coulter) + +2018-02-14 (bug)[9fd5c6] crash in object deletion, test oo-11.5 (coulter) + +2018-02-14 (bug)[3c32a3] crash deleting object with class mixed in (coulter) + +2018-02-15 (platform) stop using -lieee, removed from glibc-2.27 (porter) +***POTENTIAL INCOMPATIBILITY for math programs that embed Tcl*** + +2018-02-23 (bug)[8e6a9a] bad binary [string match], test string-11.55 (porter) + +2018-03-05 (bug)[1873ea] repair multi-thread std channel init (sebres) + + + + +- Released 8.6.9, October 17, 2017 - http://core.tcl-lang.org/tcl/ for details - -- cgit v0.12 From af3a20ad4e5a3f11a36e905a9f550e1e55b7dd38 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 11 Oct 2018 11:48:32 +0000 Subject: Mark test macOSXFCmf-2.8 non-portable. It appears to pass when the older HFS+ filesystem is in use, often on disk drives in older systems. It appears to fail when APFS is in use, more typical on newer SSD storage. --- tests/macOSXFCmd.test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/macOSXFCmd.test b/tests/macOSXFCmd.test index 132b2fe..f1758f5 100644 --- a/tests/macOSXFCmd.test +++ b/tests/macOSXFCmd.test @@ -99,7 +99,7 @@ test macOSXFCmd-2.6 {MacOSXSetFileAttribute - hidden} {macosxFileAttr notRoot} { [catch {file attributes foo.test -hidden} msg] $msg \ [file delete -force -- foo.test] } {0 {} 0 1 {}} -test macOSXFCmd-2.7 {MacOSXSetFileAttribute - rsrclength} {macosxFileAttr notRoot} { +test macOSXFCmd-2.7 {MacOSXSetFileAttribute - rsrclength} {macosxFileAttr notRoot nonPortable} { catch {file delete -force -- foo.test} close [open foo.test w] catch { -- cgit v0.12 From a221655e1a955a3408ca1be006697de2cf25be19 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 11 Oct 2018 17:17:37 +0000 Subject: More updates to changes file. --- changes | 38 +++++++++++++++++++++++++++++++++++++- 1 file changed, 37 insertions(+), 1 deletion(-) diff --git a/changes b/changes index 1d5ba66..826a322 100644 --- a/changes +++ b/changes @@ -8833,6 +8833,8 @@ improvements to regexp engine from Postgres (lane,porter,fellows,seltenreich) 2018-02-11 (enhance) stop blocking conversion of object to/from class (coulter) +2018-02-12 (enhance) NR-enable [package require] (coulter) + 2018-02-14 (bug)[9fd5c6] crash in object deletion, test oo-11.5 (coulter) 2018-02-14 (bug)[3c32a3] crash deleting object with class mixed in (coulter) @@ -8844,7 +8846,41 @@ improvements to regexp engine from Postgres (lane,porter,fellows,seltenreich) 2018-03-05 (bug)[1873ea] repair multi-thread std channel init (sebres) +2018-03-09 (bug)[db36fa] broken bytecode for index values (porter) + +2018-03-13 (bug) broken compiled [string replace], test string-14.19 (porter) + +2018-03-14 (bug) [string trim*] engine crashed on invalid UTF (sebres) + +2018-04-17 (bug) missing trace in compiled [array set], test var-20.11 (porter) + +2018-04-22 (bug)[46a241] crash in unset array with search, var-13.[23] (goth) + +2018-04-30 (bug)[27b682] race made [file delete] raise "no such file" (sebres) + +2018-05-04 tzdata updated to Olson's tzdata2017c (jima) + +2018-06-04 (bug)[925643] 32/64 cleanup of filesystem DIR operations (sebres) + +2018-06-18 (bug) leaks in TclSetEnv and env cache (coulter) + +2018-06-24 (bug)[3592747] [yieldto] dying namespace, tailcall-14.1 (coulter) + +2018-07-09 (bug)[270f78] race in [file mkdir] (sebres) + +2018-07-12 (bug)[3f7af0] [file delete] raised "permission denied" (sebres) + +2018-07-26 (bug)[d051b7] overflow crash in [format] (sebres) + +2018-08-29 revised quoting of [exec] args in generated command line (sebres) +***POTENTIAL INCOMPATIBILITY*** + +2018-09-20 HTTP Keep-Alive with pipelined requests (nash) +=> http 2.9.0 +2018-09-27 (new)[TIP 505] [lreplace] accepts all out of range indices (porter) +2018-10-04 (bug) Prevent crash from NULL keyName (nijtmans) +=> registry 1.3.3 -- Released 8.6.9, October 17, 2017 - http://core.tcl-lang.org/tcl/ for details - +- Released 8.6.9, October 17, 2018 - http://core.tcl-lang.org/tcl/ for details - -- cgit v0.12 From 7c859988ba9114dbd02e99ca9bcd621690be101a Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 11 Oct 2018 17:47:05 +0000 Subject: Revert addition of "slowTest" as built-in constraint. (no TIP; no version bump). Let the test file that needs the constraint define it with existing facilities. --- library/tcltest/tcltest.tcl | 4 ---- tests/tcltest.test | 2 +- tests/winPipe.test | 1 + 3 files changed, 2 insertions(+), 5 deletions(-) diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index eb42ff1..f1b6082 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -1254,10 +1254,6 @@ proc tcltest::DefineConstraintInitializers {} { ConstraintInitializer interactive \ {expr {[info exists ::tcl_interactive] && $::tcl_interactive}} - # Skip slow tests (to enable slow tests add parameter `-constraints slowTest`) - - ConstraintInitializer slowTest {format 0} - # Some tests can only be run if the installation came from a CD # image instead of a web image. Some tests must be skipped if you # are running as root on Unix. Other tests can only be run if you diff --git a/tests/tcltest.test b/tests/tcltest.test index e176b0c..0bcf342 100644 --- a/tests/tcltest.test +++ b/tests/tcltest.test @@ -312,7 +312,7 @@ test tcltest-5.5 {InitConstraints: list of built-in constraints} \ -result [lsort { 95 98 asyncPipeClose eformat emptyTest exec hasIsoLocale interactive knownBug mac macCrash macOnly macOrPc macOrUnix macOrWin nonBlockFiles - nonPortable notRoot nt pc pcCrash pcOnly root singleTestInterp slowTest socket + nonPortable notRoot nt pc pcCrash pcOnly root singleTestInterp socket stdio tempNotMac tempNotPc tempNotUnix tempNotWin unix unixCrash unixExecs unixOnly unixOrPc unixOrWin userInteraction win winCrash winOnly }] diff --git a/tests/winPipe.test b/tests/winPipe.test index 2f59e96..b3624c2 100644 --- a/tests/winPipe.test +++ b/tests/winPipe.test @@ -30,6 +30,7 @@ testConstraint cat32 [file exists $cat32] testConstraint AllocConsole [catch {puts console1 ""}] testConstraint RealConsole [expr {![testConstraint AllocConsole]}] testConstraint testexcept [llength [info commands testexcept]] +testConstraint slowTest 0 set big bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb\n -- cgit v0.12 From 359b371edd4b8a1b17f304f27fb30c89ad9ae8b0 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 14 Oct 2018 09:17:16 +0000 Subject: Move header parsing to where it belongs --- library/http/http.tcl | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/library/http/http.tcl b/library/http/http.tcl index 56dc67b..e843ec8 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -2721,6 +2721,11 @@ proc http::Event {sock token} { set state(connection) \ [string trim [string tolower $value]] } + set-cookie { + if {$http(-cookiejar) ne ""} { + ParseCookie $token [string trim $value] + } + } } lappend state(meta) $key [string trim $value] } @@ -2867,11 +2872,6 @@ proc http::Event {sock token} { ##Log non-chunk [string length $state(body)] -\ token $token } - set-cookie { - if {$http(-cookiejar) ne ""} { - ParseCookie $token [string trim $value] - } - } } # This calculation uses n from the -handler, chunked, or # unchunked case as appropriate. -- cgit v0.12 From 239ba78ee454f3184deca7019c7bb76c8a1d0cde Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 14 Oct 2018 10:51:27 +0000 Subject: Adapt the code to the fact that we don't need to stick to the BMP any more --- library/http/idna.tcl | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/library/http/idna.tcl b/library/http/idna.tcl index 53e45ca..030ed82 100644 --- a/library/http/idna.tcl +++ b/library/http/idna.tcl @@ -66,9 +66,7 @@ namespace eval ::tcl::idna { variable initial_bias 72 variable initial_n 0x80 - variable max_codepoint 0xFFFF ;# 0x10FFFF would be correct, except Tcl - # can't handle non-BMP characters right now - # anyway. + variable max_codepoint 0x10FFFF proc adapt {delta first numchars} { variable base @@ -263,7 +261,8 @@ namespace eval ::tcl::idna { throw {PUNYCODE OVERFLOW} \ "excessively large integer computed in character choice" } elseif {$n > $max_codepoint} { - if {$n < 0x10ffff} { + if {$n >= 0x00d800 && $n < 0x00e000} { + # Bare surrogate?! throw {PUNYCODE NON_BMP} \ [format "unsupported character U+%06x" $n] } -- cgit v0.12 From c393791ed58a2404db6365b8f76c9e8cf038ff70 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 14 Oct 2018 13:14:10 +0000 Subject: Added documentation --- doc/cookiejar.n | 167 ++++++++++++++++++++++++++++++++++++++++++++++++++ doc/http.n | 110 +++++++++++++++++++++++++++++++++ library/http/http.tcl | 13 +++- 3 files changed, 288 insertions(+), 2 deletions(-) create mode 100644 doc/cookiejar.n diff --git a/doc/cookiejar.n b/doc/cookiejar.n new file mode 100644 index 0000000..61f2243 --- /dev/null +++ b/doc/cookiejar.n @@ -0,0 +1,167 @@ +'\" +'\" Copyright (c) 2014-2018 Donal K. Fellows. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +.TH "cookiejar" n 0.1 cookiejar "Tcl Bundled Packages" +.so man.macros +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +cookiejar \- Implementation of the Tcl http package cookie jar protocol +.SH SYNOPSIS +.nf +\fBpackage require\fR \fBcookiejar\fR ?\fB0.1\fR? + +\fB::http::cookiejar configure\fR ?\fIoptionName\fR? ?\fIoptionValue\fR? +\fB::http::cookiejar create\fR \fIname\fR ?\fIfilename\fR? +\fB::http::cookiejar new\fR ?\fIfilename\fR? + +\fIcookiejar\fR \fBdestroy\fR +\fIcookiejar\fR \fBforceLoadDomainData\fR +\fIcookiejar\fR \fBgetCookies\fR \fIprotocol host path\fR +\fIcookiejar\fR \fBstoreCookie\fR \fIoptions\fR +\fIcookiejar\fR \fBlookup\fR ?\fIhost\fR? ?\fIkey\fR? +.fi +.SH DESCRIPTION +.PP +The cookiejar package provides an implementation of the http package's cookie +jar protocol using an SQLite database. It provides one main command, +\fB::http::cookiejar\fR, which is a TclOO class that should be instantiated to +create a cookie jar that manages a particular HTTP session. +.PP +The database management policy can be controlled at the package level by the +\fBconfigure\fR method on the \fB::http::cookiejar\fR class object: +.TP +\fB::http::cookiejar configure\fR ?\fIoptionName\fR? ?\fIoptionValue\fR? +. +If neither \fIoptionName\fR nor \fIoptionValue\fR are supplied, this returns a +copy of the configuration as a Tcl dictionary. If just \fIoptionName\fR is +supplied, just the value of the named option is returned. If both +\fIoptionName\fR and \fIoptionValue\fR are given, the named option is changed +to be the given value. +.RS +.PP +Supported options are: +.TP +\fB\-domainfile \fIfilename\fR +. +A file (defaulting to within the cookiejar package) with a description of the +list of top-level domains (e.g., \fB.com\fR or \fB.co.jp\fR). Such domains +\fImust not\fR accept cookies set upon them. Note that the list of such +domains is both security-sensitive and \fInot\fR constant and should be +periodically refetched. Cookie jars maintain their own cache of the domain +list. +.TP +\fB\-domainlist \fIurl\fR +. +A URL to fetch the list of top-level domains (e.g., \fB.com\fR or +\fB.co.jp\fR) from. Such domains \fImust not\fR accept cookies set upon +them. Note that the list of such domains is both security-sensitive and +\fInot\fR constant and should be periodically refetched. Cookie jars maintain +their own cache of the domain list. +.TP +\fB\-domainrefresh \fIintervalMilliseconds\fR +. +The number of milliseconds between checks of the \fI\-domainlist\fR for new +domains. +.TP +\fB\-loglevel \fIlevel\fR +. +The logging level of this package. The logging level must be (in order of +decreasing verbosity) one of \fBdebug\fR, \fBinfo\fR, \fBwarn\fR, or +\fBerror\fR. +.TP +\fB\-offline \fIflag\fR +. +Allows the cookie managment engine to be placed into offline mode. In offline +mode, the list of domains is read immediately from the file configured in the +\fB\-domainfile\fR option, and the \fB\-domainlist\fR option is not used; it +also makes the \fB\-domainrefresh\fR option be effectively ignored. +.TP +\fB\-purgeold \fIintervalMilliseconds\fR +. +The number of milliseconds between checks of the database for expired +cookies; expired cookies are deleted. +.TP +\fB\-retain \fIcookieCount\fR +. +The maximum number of cookies to retain in the database. +.TP +\fB\-vacuumtrigger \fIdeletionCount\fR +. +A count of the number of persistent cookie deletions to go between vacuuming +the database. +.RE +.PP +Cookie jar instances may be made with any of the standard TclOO instance +creation methods (\fBcreate\fR or \fRnew\fR). +.TP +\fB::http::cookiejar new\fR ?\fIfilename\fR? +. +If a \fIfilename\fR argument is provided, it is the name of a file containing +an SQLite database that will contain the persistent cookies maintained by the +cookie jar; the database will be created if the file does not already +exist. If \fIfilename\fR is not supplied, the database will be held entirely within +memory, which effectively forces all cookies within it to be session cookies. +.SS "INSTANCE METHODS" +.PP +The following methods are supported on the instances: +.TP +\fIcookiejar\fR \fBdestroy\fR +. +This is the standard TclOO destruction method. It does \fInot\fR delete the +SQLite database if it is written to disk. Callers are responsible for ensuring +that the cookie jar is not in use by the http package at the time of +destruction. +.TP +\fIcookiejar\fR \fBforceLoadDomainData\fR +. +This method causes the cookie jar to immediately load (and cache) the domain +list data. The domain list will be loaded from the \fB\-domainlist\fR +configured a the package level if that is enabled, and otherwise will be +obtained from the \fB\-domainfile\fR configured at the package level. +.TP +\fIcookiejar\fR \fBgetCookies\fR \fIprotocol host path\fR +. +This method obtains the cookies for a particular HTTP request. \fIThis +implements the http cookie jar protocol.\fR +.TP +\fIcookiejar\fR \fBstoreCookie\fR \fIoptions\fR +. +This method stores a single cookie from a particular HTTP response. Cookies +that fail security checks are ignored. \fIThis implements the http cookie jar +protocol.\fR +.TP +\fIcookiejar\fR \fBlookup\fR ?\fIhost\fR? ?\fIkey\fR? +. +This method looks a cookie by exact host (or domain) matching. If neither +\fIhost\fR nor \fIkey\fR are supplied, the list of hosts for which a cookie is +stored is returned. If just \fIhost\fR (which may be a hostname or a domain +name) is supplied, the list of cookie keys stored for that host is returned. +If both \fIhost\fR and \fIkey\fR are supplied, the value for that key is +returned; it is an error if no such host or key match exactly. +.SH "EXAMPLE" +.PP +The simplest way of using a cookie jar is to just permanently configure it at +the start of the application. +.PP +.CS +package require http +\fBpackage require cookiejar\fR + +set cookiedb ~/.tclcookies.db +http::configure -cookiejar [\fBhttp::cookiejar new\fR $cookiedb] + +# No further explicit steps are required to use cookies +set tok [http::geturl http://core.tcl.tk/] +.CE +.SH "SEE ALSO" +http(n), oo::class(n), sqlite3(n) +.SH KEYWORDS +cookie, internet, security policy, www +'\" Local Variables: +'\" mode: nroff +'\" fill-column: 78 +'\" End: diff --git a/doc/http.n b/doc/http.n index a986704..b24cce0 100644 --- a/doc/http.n +++ b/doc/http.n @@ -99,6 +99,15 @@ comma-separated list of mime type patterns that you are willing to receive. For example, .QW "image/gif, image/jpeg, text/*" . .TP +\fB\-cookiejar\fR \fIcommand\fR +.VS TIP406 +The cookie store for the package to use to manage HTTP cookies. +\fIcommand\fR is a command prefix list; if the empty list (the +default value) is used, no cookies will be sent by requests or stored +from responses. The command indicated by \fIcommand\fR, if supplied, +must obey the \fBCOOKIE JAR PROTOCOL\fR described below. +.VE TIP406 +.TP \fB\-pipeline\fR \fIboolean\fR . Specifies whether HTTP/1.1 transactions on a persistent socket will be @@ -770,6 +779,107 @@ Subsequent GET and HEAD requests in a failed pipeline will also be retried. that the retry is appropriate\fR - specifically, the application must know that if the failed POST successfully modified the state of the server, a repeat POST would have no adverse effect. +.VS TIP406 +.SH "COOKIE JAR PROTOCOL" +.PP +Cookies are short key-value pairs used to implement sessions within the +otherwise-stateless HTTP protocol. \fB(TODO: CITE RFC)\fR +.PP +Cookie storage managment commands \(em +.QW "cookie jars" +\(em must support these subcommands which form the HTTP cookie storage +management protocol. Note that \fIcookieJar\fR below does not have to be a +command name; it is properly a command prefix (a Tcl list of words that will +be expanded in place) and admits many possible implementations. +.PP +Though not formally part of the protocol, it is expected that particular +values of \fIcookieJar\fR will correspond to sessions; it is up to the caller +of \fB::http::config\fR to decide what session applies and to manage the +deletion of said sessions when they are no longer desired (which should be +when they not configured as the current cookie jar). +.TP +\fIcookieJar \fBgetCookies \fIprotocol host requestPath\fR +. +This command asks the cookie jar what cookies should be supplied for a +particular request. It should take the \fIprotocol\fR (typically \fBhttp\fR or +\fBhttps\fR), \fIhost\fR name and \fIrequestPath\fR (parsed from the \fIurl\fR +argument to \fB::http::geturl\fR) and return a list of cookie keys and values +that describe the cookies to supply to the remote host. The list must have an +even number of elements. +.RS +.PP +There should only ever be at most one cookie with a particular key for any +request (typically the one with the most specific \fIhost\fR/domain match and +most specific \fIrequestPath\fR/path match), but there may be many cookies +with different names in any request. +.RE +.TP +\fIcookieJar \fBstoreCookie \fIcookieDictionary\fR +. +This command asks the cookie jar to store a particular cookie that was +returned by a request. The cookie (which will have been parsed by the http +package) is described by a dictionary, \fIcookieDictionary\fR, that may have +the following keys: +.RS +.TP +\fBdomain\fR +. +This is always present. Its value describes the domain hostname \fIor +prefix\fR that the cookie should be returned for. The checking of the domain +against the origin (below) should be careful since sites that issue cookies +should only do so for domains related to themselves. Cookies that do not obey +a relevant origin matching rule should be ignored. +.TP +\fBexpires\fR +. +This is optional. If present, the cookie is intended to be a persistent cookie +and the value of the option is the Tcl timestamp (in seconds from the same +base as \fBclock seconds\fR) of when the cookie expires (which may be in the +past, which should result in the cookie being deleted immediately). If absent, +the cookie is intended to be a session cookie that should be not persisted +beyond the lifetime of the cookie jar. +.TP +\fBhostonly\fR +. +This is always present. Its value is a boolean that describes whether the +cookie is a single host cookie (true) or a domain-level cookie (false). +.TP +\fBhttponly\fR +. +This is always present. Its value is a boolean that is true when the site +wishes the cookie to only ever be used with HTTP (or HTTPS) traffic. +.TP +\fBkey\fR +. +This is always present. Its value is the \fIkey\fR of the cookie, which is +part of the information that must be return when sending this cookie back in a +future request. +.TP +\fBorigin\fR +. +This is always present. Its value describes where the http package believes it +received the cookie from, which may be useful for checking whether the +cookie's domain is valid. +.TP +\fBpath\fR +. +This is always present. Its value describes the path prefix of requests to the +cookie domain where the cookie should be returned. +.TP +\fBsecure\fR +. +This is always present. Its value is a boolean that is true when the cookie +should only used on requests sent over secure channels (typically HTTPS). +.TP +\fBvalue\fR +. +This is always present. Its value is the value of the cookie, which is part of +the information that must be return when sending this cookie back in a future +request. +.PP +Other keys may always be ignored; they have no meaning in this protocol. +.RE +.VE TIP406 .SH EXAMPLE .PP This example creates a procedure to copy a URL to a file while printing a diff --git a/library/http/http.tcl b/library/http/http.tcl index e843ec8..7236bae 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -20,6 +20,7 @@ namespace eval http { if {![info exists http]} { array set http { -accept */* + -cookiejar {} -pipeline 1 -postfresh 0 -proxyhost {} @@ -28,7 +29,6 @@ namespace eval http { -repost 0 -urlencoding utf-8 -zip 1 - -cookiejar {} } # We need a useragent string of this style or various servers will # refuse to send us compressed content even when we ask for it. This @@ -129,7 +129,16 @@ namespace eval http { } # Regular expression used to parse cookies - variable CookieRE {\s*([^][\u0000- ()<>@,;:\\""/?={}\u007f-\uffff]+)=([!\u0023-+\u002D-:<-\u005B\u005D-~]*)(?:\s*;\s*([^\u0000]+))?} + variable CookieRE {(?x) # EXPANDED SYNTAX + \s* # Ignore leading spaces + ([^][\u0000- ()<>@,;:\\""/?={}\u007f-\uffff]+) # Match the name + = # LITERAL: Equal sign + ([!\u0023-+\u002D-:<-\u005B\u005D-~]*) # Match the value + (?: + \s* ; \s* # LITERAL: semicolon + ([^\u0000]+) # Match the options + )? + } namespace export geturl config reset wait formatQuery quoteString namespace export register unregister registerError -- cgit v0.12 From 61a92173ccef8146d1297dc6b4d8fbe602f805cf Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 14 Oct 2018 13:48:11 +0000 Subject: Added more documentation. --- doc/cookiejar.n | 2 +- doc/idna.n | 88 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 89 insertions(+), 1 deletion(-) create mode 100644 doc/idna.n diff --git a/doc/cookiejar.n b/doc/cookiejar.n index 61f2243..bbfd9a3 100644 --- a/doc/cookiejar.n +++ b/doc/cookiejar.n @@ -4,7 +4,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.TH "cookiejar" n 0.1 cookiejar "Tcl Bundled Packages" +.TH "cookiejar" n 0.1 http "Tcl Bundled Packages" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! diff --git a/doc/idna.n b/doc/idna.n new file mode 100644 index 0000000..c7e8bf7 --- /dev/null +++ b/doc/idna.n @@ -0,0 +1,88 @@ +'\" +'\" Copyright (c) 2014-2018 Donal K. Fellows. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +.TH "idna" n 0.1 http "Tcl Bundled Packages" +.so man.macros +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +tcl::idna \- Support for normalization of Internationalized Domain Names +.SH SYNOPSIS +.nf +package require tcl::idna 1.0 + +\fBtcl::idna decode\fR \fIhostname\fR +\fBtcl::idna encode\fR \fIhostname\fR +\fBtcl::idna puny decode\fR \fIstring\fR ?\fIcase\fR? +\fBtcl::idna puny encode\fR \fIstring\fR ?\fIcase\fR? +\fBtcl::idna version\fR +.fi +.SH DESCRIPTION +This package provides an implementation of the punycode scheme used in +Internationalised Domain Names, and some access commands. +'\" TODO: Cite the punycode definition RFC +.TP +\fBtcl::idna decode\fR \fIhostname\fR +. +This command takes the name of a host that potentially contains +punycode-encoded character sequences, \fIhostname\fR, and returns the hostname +as might be displayed to the user. Note that there are often UNICODE +characters that have extremely similar glyphs, so care should be taken with +displaying hostnames to users. +.TP +\fBtcl::idna encode\fR \fIhostname\fR +. +This command takes the name of a host as might be displayed to the user, +\fIhostname\fR, and returns the version of the hostname with characters not +permitted in basic hostnames encoded with punycode. +.TP +\fBtcl::idna puny\fR \fIsubcommand ...\fR +. +This command provides direct access to the basic punycode encoder and +decoder. It supports two \fIsubcommand\fRs: +.RS +.TP +\fBtcl::idna puny decode\fR \fIstring\fR ?\fIcase\fR? +. +This command decodes the punycode-encoded string, \fIstring\fR, and returns +the result. If \fIcase\fR is provided, it is a boolean to make the case be +folded to upper case (if \fIcase\fR is true) or lower case (if \fIcase\fR is +false) during the decoding process; if omitted, no case transformation is +applied. +.TP +\fBtcl::idna puny encode\fR \fIstring\fR ?\fIcase\fR? +. +This command encodes the string, \fIstring\fR, and returns the +punycode-encoded version of the string. If \fIcase\fR is provided, it is a +boolean to make the case be folded to upper case (if \fIcase\fR is true) or +lower case (if \fIcase\fR is false) during the encoding process; if omitted, +no case transformation is applied. +.RE +.TP +\fBtcl::idna version\fR +. +This returns the version of the \fBtcl::idna\fR package. +.SH "EXAMPLE" +.PP +This is an example of how punycoding of a string works: +.PP +.CS +package require tcl::idna + +puts [\fBtcl::idna puny encode\fR "abc\(->def"] +# prints: \fIabcdef-kn2c\fR +puts [\fBtcl::idna puny decode\fR "abcdef-kn2c"] +# prints: \fIabc\(->def\fR +.CE +'\" TODO: show how it handles a real domain name +.SH "SEE ALSO" +http(n), cookiejar(n) +.SH KEYWORDS +internet, www +'\" Local Variables: +'\" mode: nroff +'\" fill-column: 78 +'\" End: -- cgit v0.12 From 94c0eede77a9bc36e35be21b052a319c0e451047 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 14 Oct 2018 14:00:38 +0000 Subject: Fix up citations --- doc/http.n | 3 ++- doc/idna.n | 4 ++-- library/http/idna.tcl | 4 ++++ 3 files changed, 8 insertions(+), 3 deletions(-) diff --git a/doc/http.n b/doc/http.n index b24cce0..572f19a 100644 --- a/doc/http.n +++ b/doc/http.n @@ -783,7 +783,8 @@ would have no adverse effect. .SH "COOKIE JAR PROTOCOL" .PP Cookies are short key-value pairs used to implement sessions within the -otherwise-stateless HTTP protocol. \fB(TODO: CITE RFC)\fR +otherwise-stateless HTTP protocol. (See RFC 6265 for details; Tcl does not +implement the Cookie2 protocol as that is rarely seen in the wild.) .PP Cookie storage managment commands \(em .QW "cookie jars" diff --git a/doc/idna.n b/doc/idna.n index c7e8bf7..744bf67 100644 --- a/doc/idna.n +++ b/doc/idna.n @@ -22,8 +22,8 @@ package require tcl::idna 1.0 .fi .SH DESCRIPTION This package provides an implementation of the punycode scheme used in -Internationalised Domain Names, and some access commands. -'\" TODO: Cite the punycode definition RFC +Internationalised Domain Names, and some access commands. (See RFC 3492 for a +description of punycode.) .TP \fBtcl::idna decode\fR \fIhostname\fR . diff --git a/library/http/idna.tcl b/library/http/idna.tcl index 030ed82..2a7d289 100644 --- a/library/http/idna.tcl +++ b/library/http/idna.tcl @@ -5,6 +5,10 @@ # 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. -- cgit v0.12 From f59c9faee29435ebeef786b6662a092e18ec0b18 Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 15 Oct 2018 10:28:23 +0000 Subject: Make it easier to extend cookiejar for policy reasons --- doc/cookiejar.n | 52 +++++++++++++++++++++++++++++++++++++++++++++- doc/http.n | 6 +++--- library/http/cookiejar.tcl | 18 ++++++++++++++++ 3 files changed, 72 insertions(+), 4 deletions(-) diff --git a/doc/cookiejar.n b/doc/cookiejar.n index bbfd9a3..ac71759 100644 --- a/doc/cookiejar.n +++ b/doc/cookiejar.n @@ -128,6 +128,33 @@ obtained from the \fB\-domainfile\fR configured at the package level. This method obtains the cookies for a particular HTTP request. \fIThis implements the http cookie jar protocol.\fR .TP +\fIcookiejar\fR \fBpolicyAllow\fR \fIoperation domain path\fR +. +This method is called by the \fBstoreCookie\fR method to get a decision on +whether to allow \fIoperation\fR to be performed for the \fIdomain\fR and +\fIpath\fR. This is checked immediately before the database is updated but +after the built-in security checks are done, and should return a boolean +value; if the value is false, the operation is rejected and the database is +not modified. The supported \fIoperation\fRs are: +.RS +.TP +\fBdelete\fR +. +The \fIdomain\fR is seeking to delete a cookie. +.TP +\fBsession\fR +. +The \fIdomain\fR is seeking to create or update a session cookie. +.TP +\fBset\fR +. +The \fIdomain\fR is seeking to create or update a persistent cookie (with a +defined lifetime). +.PP +The default implementation of this method just returns true, but subclasses of +this class may impose their own rules. +.RE +.TP \fIcookiejar\fR \fBstoreCookie\fR \fIoptions\fR . This method stores a single cookie from a particular HTTP response. Cookies @@ -142,7 +169,7 @@ stored is returned. If just \fIhost\fR (which may be a hostname or a domain name) is supplied, the list of cookie keys stored for that host is returned. If both \fIhost\fR and \fIkey\fR are supplied, the value for that key is returned; it is an error if no such host or key match exactly. -.SH "EXAMPLE" +.SH "EXAMPLES" .PP The simplest way of using a cookie jar is to just permanently configure it at the start of the application. @@ -157,6 +184,29 @@ http::configure -cookiejar [\fBhttp::cookiejar new\fR $cookiedb] # No further explicit steps are required to use cookies set tok [http::geturl http://core.tcl.tk/] .CE +.PP +To only allow a particular domain to use cookies, perhaps because you only +want to enable a particular host to create and manipulate sessions, create a +subclass that imposes that policy. +.PP +.CS +package require http +\fBpackage require cookiejar\fR + +oo::class create MyCookieJar { + superclass \fBhttp::cookiejar\fR + + method \fBpolicyAllow\fR {operation domain path} { + return [expr {$domain eq "my.example.com"}] + } +} + +set cookiedb ~/.tclcookies.db +http::configure -cookiejar [MyCookieJar new $cookiedb] + +# No further explicit steps are required to use cookies +set tok [http::geturl http://core.tcl.tk/] +.CE .SH "SEE ALSO" http(n), oo::class(n), sqlite3(n) .SH KEYWORDS diff --git a/doc/http.n b/doc/http.n index 572f19a..7845e60 100644 --- a/doc/http.n +++ b/doc/http.n @@ -818,9 +818,9 @@ with different names in any request. \fIcookieJar \fBstoreCookie \fIcookieDictionary\fR . This command asks the cookie jar to store a particular cookie that was -returned by a request. The cookie (which will have been parsed by the http -package) is described by a dictionary, \fIcookieDictionary\fR, that may have -the following keys: +returned by a request; the result of this command is ignored. The cookie +(which will have been parsed by the http package) is described by a +dictionary, \fIcookieDictionary\fR, that may have the following keys: .RS .TP \fBdomain\fR diff --git a/library/http/cookiejar.tcl b/library/http/cookiejar.tcl index 1fc1ffe..309ca7a 100644 --- a/library/http/cookiejar.tcl +++ b/library/http/cookiejar.tcl @@ -589,6 +589,12 @@ package provide cookiejar \ 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]} { @@ -598,6 +604,10 @@ package provide cookiejar \ 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, @@ -612,6 +622,10 @@ package provide cookiejar \ 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 @@ -627,6 +641,10 @@ package provide cookiejar \ 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, -- cgit v0.12 From 4dbcfc37b33a496443fc53bd18c1e6a5c9ada589 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 15 Oct 2018 12:49:56 +0000 Subject: typo --- changes | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/changes b/changes index 826a322..62fdd4e 100644 --- a/changes +++ b/changes @@ -8858,7 +8858,7 @@ improvements to regexp engine from Postgres (lane,porter,fellows,seltenreich) 2018-04-30 (bug)[27b682] race made [file delete] raise "no such file" (sebres) -2018-05-04 tzdata updated to Olson's tzdata2017c (jima) +2018-05-04 tzdata updated to Olson's tzdata2017e (jima) 2018-06-04 (bug)[925643] 32/64 cleanup of filesystem DIR operations (sebres) -- cgit v0.12 From d32d625787febc9c08fa7e1118df87ebfd4a9315 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 20 Oct 2018 11:57:59 +0000 Subject: Travis CI build --- .travis.yml | 63 ++++++++++++++++++++++ README.md | 172 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 235 insertions(+) create mode 100644 .travis.yml create mode 100644 README.md diff --git a/.travis.yml b/.travis.yml new file mode 100644 index 0000000..3abeb6b --- /dev/null +++ b/.travis.yml @@ -0,0 +1,63 @@ +dist: trusty +language: c +matrix: + include: + - os: linux + env: + - MATRIX_EVAL="BUILD_DIR=unix" + - os: linux + addons: + apt: + sources: + - ubuntu-toolchain-r-test + packages: + - g++-4.9 + env: + - MATRIX_EVAL="CC=gcc-4.9 && BUILD_DIR=unix" + - os: linux + addons: + apt: + sources: + - ubuntu-toolchain-r-test + packages: + - g++-5 + env: + - MATRIX_EVAL="CC=gcc-5 && BUILD_DIR=unix" + - os: linux + addons: + apt: + sources: + - ubuntu-toolchain-r-test + packages: + - g++-6 + env: + - MATRIX_EVAL="CC=gcc-6 && BUILD_DIR=unix" + - os: linux + addons: + apt: + sources: + - ubuntu-toolchain-r-test + packages: + - g++-7 + env: + - MATRIX_EVAL="CC=gcc-7 && BUILD_DIR=unix" + - os: osx + osx_image: xcode8 + env: + - MATRIX_EVAL="BUILD_DIR=unix" + - os: osx + osx_image: xcode8 + env: + - MATRIX_EVAL="BUILD_DIR=macosx" + - os: windows + env: + - MATRIX_EVAL="BUILD_DIR=win" + +before_install: + - eval "${MATRIX_EVAL}" + - cd ${BUILD_DIR} +install: + - ./configure +script: + - make + - make test diff --git a/README.md b/README.md new file mode 100644 index 0000000..db67791 --- /dev/null +++ b/README.md @@ -0,0 +1,172 @@ +README: Tcl +============ +This is the **Tcl 8.5.19** source distribution. + +You can get any source release of Tcl from [our distribution +site](https://sourceforge.net/projects/tcl/files/Tcl/). + +[![Build Status](https://travis-ci.org/tcltk/tcl.svg?branch=core-8-5-branch)](https://travis-ci.org/tcltk/tcl) + +Contents +-------- + 1. [Introduction](#intro) + 2. [Documentation](#doc) + 3. [Compiling and installing Tcl](#build) + 4. [Development tools](#devtools) + 5. [Tcl newsgroup](#complangtcl) + 6. [The Tcler's Wiki](#wiki) + 7. [Mailing lists](#email) + 8. [Support and Training](#support) + 9. [Tracking Development](#watch) + 10. [Thank You](#thanks) + +1. Introduction +--------------- +Tcl provides a powerful platform for creating integration applications that +tie together diverse applications, protocols, devices, and frameworks. +When paired with the Tk toolkit, Tcl provides the fastest and most powerful +way to create GUI applications that run on PCs, Unix, and Mac OS X. +Tcl can also be used for a variety of web-related tasks and for creating +powerful command languages for applications. + +Tcl is maintained, enhanced, and distributed freely by the Tcl community. +Source code development and tracking of bug reports and feature requests +takes place at [core.tcl-lang.org](https://core.tcl-lang.org/). +Tcl/Tk release and mailing list services are [hosted by +SourceForge](https://sourceforge.net/projects/tcl/) +with the Tcl Developer Xchange hosted at +[www.tcl-lang.org](https://www.tcl-lang.org). + +Tcl is a freely available open source package. You can do virtually +anything you like with it, such as modifying it, redistributing it, +and selling it either in whole or in part. See the file +`license.terms` for complete information. + +2. Documentation +---------------- + +Extensive documentation is available at our website. +The home page for this release, including new features, is +[here](https://www.tcl.tk/software/tcltk/8.5.html). +Detailed release notes can be found at the +[file distributions page](https://sourceforge.net/projects/tcl/files/Tcl/) +by clicking on the relevant version. + +Information about Tcl itself can be found at the [Developer +Xchange](https://www.tcl-lang.org/about/). +There have been many Tcl books on the market. Many are mentioned in +[the Wiki](https://wiki.tcl-lang.org/_/ref?N=25206). + +The complete set of reference manual entries for Tcl 8.5 is [online, +here](https://www.tcl-lang.org/man/tcl8.5/). + +2a. Unix Documentation +---------------------- + +The `doc` subdirectory in this release contains a complete set of +reference manual entries for Tcl. Files with extension "`.1`" are for +programs (for example, `tclsh.1`); files with extension "`.3`" are for C +library procedures; and files with extension "`.n`" describe Tcl +commands. The file "`doc/Tcl.n`" gives a quick summary of the Tcl +language syntax. To print any of the man pages on Unix, cd to the +"doc" directory and invoke your favorite variant of troff using the +normal -man macros, for example + + groff -man -Tpdf Tcl.n >output.pdf + +to print Tcl.n to PDF. If Tcl has been installed correctly and your "man" program +supports it, you should be able to access the Tcl manual entries using the +normal "man" mechanisms, such as + + man Tcl + +2b. Windows Documentation +------------------------- + +The "doc" subdirectory in this release contains a complete set of Windows +help files for Tcl. Once you install this Tcl release, a shortcut to the +Windows help Tcl documentation will appear in the "Start" menu: + + Start | Programs | Tcl | Tcl Help + +3. Compiling and installing Tcl +------------------------------- + +There are brief notes in the `unix/README`, `win/README`, and `macosx/README` +about compiling on these different platforms. There is additional information +about building Tcl from sources +[online](https://www.tcl-lang.org/doc/howto/compile.html). + +4. Development tools +--------------------------- + +ActiveState produces a high quality set of commercial quality development +tools that is available to accelerate your Tcl application development. +Tcl Dev Kit builds on the earlier TclPro toolset and provides a debugger, +static code checker, single-file wrapping utility, bytecode compiler and +more. More information can be found at + + http://www.ActiveState.com/Tcl + +5. Tcl newsgroup +---------------- + +There is a USENET news group, "`comp.lang.tcl`", intended for the exchange of +information about Tcl, Tk, and related applications. The newsgroup is a +great place to ask general information questions. For bug reports, please +see the "Support and bug fixes" section below. + +6. Tcl'ers Wiki +--------------- + +There is a [wiki-based open community site](https://wiki.tcl-lang.org/) +covering all aspects of Tcl/Tk. + +It is dedicated to the Tcl programming language and its extensions. A +wealth of useful information can be found there. It contains code +snippets, references to papers, books, and FAQs, as well as pointers to +development tools, extensions, and applications. You can also recommend +additional URLs by editing the wiki yourself. + +7. Mailing lists +---------------- + +Several mailing lists are hosted at SourceForge to discuss development or use +issues (like Macintosh and Windows topics). For more information and to +subscribe, visit [here](https://sourceforge.net/projects/tcl/) and go to the +Mailing Lists page. + +8. Support and Training +------------------------ + +We are very interested in receiving bug reports, patches, and suggestions for +improvements. We prefer that you send this information to us as tickets +entered into [our issue tracker](https://core.tcl-lang.org/tcl/reportlist). + +We will log and follow-up on each bug, although we cannot promise a +specific turn-around time. Enhancements may take longer and may not happen +at all unless there is widespread support for them (we're trying to +slow the rate at which Tcl/Tk turns into a kitchen sink). It's very +difficult to make incompatible changes to Tcl/Tk at this point, due to +the size of the installed base. + +The Tcl community is too large for us to provide much individual support for +users. If you need help we suggest that you post questions to `comp.lang.tcl` +or ask a question on [Stack +Overflow](https://stackoverflow.com/questions/tagged/tcl). We read the +newsgroup and will attempt to answer esoteric questions for which no one else +is likely to know the answer. In addition, see the wiki for [links to other +organizations](https://wiki.tcl-lang.org/training) that offer Tcl/Tk training. + +9. Tracking Development +----------------------- + +Tcl is developed in public. You can keep an eye on how Tcl is changing at +[core.tcl-lang.org](https://core.tcl-lang.org/). + +10. Thank You +------------- + +We'd like to express our thanks to the Tcl community for all the +helpful suggestions, bug reports, and patches we have received. +Tcl/Tk has improved vastly and will continue to do so with your help. -- cgit v0.12 From ea29292705d5531747a472e71d3c59e9e9518f03 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 20 Oct 2018 12:01:49 +0000 Subject: formatting fix --- README.md | 54 +++++++++++++++--------------------------------------- 1 file changed, 15 insertions(+), 39 deletions(-) diff --git a/README.md b/README.md index db67791..d5fe033 100644 --- a/README.md +++ b/README.md @@ -1,5 +1,5 @@ -README: Tcl -============ +# README: Tcl + This is the **Tcl 8.5.19** source distribution. You can get any source release of Tcl from [our distribution @@ -7,8 +7,7 @@ site](https://sourceforge.net/projects/tcl/files/Tcl/). [![Build Status](https://travis-ci.org/tcltk/tcl.svg?branch=core-8-5-branch)](https://travis-ci.org/tcltk/tcl) -Contents --------- +## Contents 1. [Introduction](#intro) 2. [Documentation](#doc) 3. [Compiling and installing Tcl](#build) @@ -20,8 +19,7 @@ Contents 9. [Tracking Development](#watch) 10. [Thank You](#thanks) -1. Introduction ---------------- +## 1. Introduction Tcl provides a powerful platform for creating integration applications that tie together diverse applications, protocols, devices, and frameworks. When paired with the Tk toolkit, Tcl provides the fastest and most powerful @@ -42,9 +40,7 @@ anything you like with it, such as modifying it, redistributing it, and selling it either in whole or in part. See the file `license.terms` for complete information. -2. Documentation ----------------- - +## 2. Documentation Extensive documentation is available at our website. The home page for this release, including new features, is [here](https://www.tcl.tk/software/tcltk/8.5.html). @@ -60,9 +56,7 @@ There have been many Tcl books on the market. Many are mentioned in The complete set of reference manual entries for Tcl 8.5 is [online, here](https://www.tcl-lang.org/man/tcl8.5/). -2a. Unix Documentation ----------------------- - +### 2a. Unix Documentation The `doc` subdirectory in this release contains a complete set of reference manual entries for Tcl. Files with extension "`.1`" are for programs (for example, `tclsh.1`); files with extension "`.3`" are for C @@ -80,26 +74,20 @@ normal "man" mechanisms, such as man Tcl -2b. Windows Documentation -------------------------- - +### 2b. Windows Documentation The "doc" subdirectory in this release contains a complete set of Windows help files for Tcl. Once you install this Tcl release, a shortcut to the Windows help Tcl documentation will appear in the "Start" menu: Start | Programs | Tcl | Tcl Help -3. Compiling and installing Tcl -------------------------------- - +## 3. Compiling and installing Tcl There are brief notes in the `unix/README`, `win/README`, and `macosx/README` about compiling on these different platforms. There is additional information about building Tcl from sources [online](https://www.tcl-lang.org/doc/howto/compile.html). -4. Development tools ---------------------------- - +## 4. Development tools ActiveState produces a high quality set of commercial quality development tools that is available to accelerate your Tcl application development. Tcl Dev Kit builds on the earlier TclPro toolset and provides a debugger, @@ -108,17 +96,13 @@ more. More information can be found at http://www.ActiveState.com/Tcl -5. Tcl newsgroup ----------------- - +## 5. Tcl newsgroup There is a USENET news group, "`comp.lang.tcl`", intended for the exchange of information about Tcl, Tk, and related applications. The newsgroup is a great place to ask general information questions. For bug reports, please see the "Support and bug fixes" section below. -6. Tcl'ers Wiki ---------------- - +## 6. Tcl'ers Wiki There is a [wiki-based open community site](https://wiki.tcl-lang.org/) covering all aspects of Tcl/Tk. @@ -128,17 +112,13 @@ snippets, references to papers, books, and FAQs, as well as pointers to development tools, extensions, and applications. You can also recommend additional URLs by editing the wiki yourself. -7. Mailing lists ----------------- - +## 7. Mailing lists Several mailing lists are hosted at SourceForge to discuss development or use issues (like Macintosh and Windows topics). For more information and to subscribe, visit [here](https://sourceforge.net/projects/tcl/) and go to the Mailing Lists page. -8. Support and Training ------------------------- - +## 8. Support and Training We are very interested in receiving bug reports, patches, and suggestions for improvements. We prefer that you send this information to us as tickets entered into [our issue tracker](https://core.tcl-lang.org/tcl/reportlist). @@ -158,15 +138,11 @@ newsgroup and will attempt to answer esoteric questions for which no one else is likely to know the answer. In addition, see the wiki for [links to other organizations](https://wiki.tcl-lang.org/training) that offer Tcl/Tk training. -9. Tracking Development ------------------------ - +## 9. Tracking Development Tcl is developed in public. You can keep an eye on how Tcl is changing at [core.tcl-lang.org](https://core.tcl-lang.org/). -10. Thank You -------------- - +## 10. Thank You We'd like to express our thanks to the Tcl community for all the helpful suggestions, bug reports, and patches we have received. Tcl/Tk has improved vastly and will continue to do so with your help. -- cgit v0.12 From e5cf3448bd80bc3f8d4b0441e759c17885c508fa Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 20 Oct 2018 12:54:28 +0000 Subject: formatting tweak --- README.md | 46 +++++++++++++++++++++++----------------------- 1 file changed, 23 insertions(+), 23 deletions(-) diff --git a/README.md b/README.md index d5fe033..cbc49f0 100644 --- a/README.md +++ b/README.md @@ -8,18 +8,18 @@ site](https://sourceforge.net/projects/tcl/files/Tcl/). [![Build Status](https://travis-ci.org/tcltk/tcl.svg?branch=core-8-5-branch)](https://travis-ci.org/tcltk/tcl) ## Contents - 1. [Introduction](#intro) - 2. [Documentation](#doc) - 3. [Compiling and installing Tcl](#build) - 4. [Development tools](#devtools) - 5. [Tcl newsgroup](#complangtcl) - 6. [The Tcler's Wiki](#wiki) - 7. [Mailing lists](#email) - 8. [Support and Training](#support) - 9. [Tracking Development](#watch) - 10. [Thank You](#thanks) - -## 1. Introduction + 1. Introduction + 2. Documentation + 3. Compiling and installing Tcl + 4. Development tools + 5. Tcl newsgroup + 6. The Tcler's Wiki + 7. Mailing lists + 8. Support and Training + 9. Tracking Development + 10. Thank You + +## 1. Introduction Tcl provides a powerful platform for creating integration applications that tie together diverse applications, protocols, devices, and frameworks. When paired with the Tk toolkit, Tcl provides the fastest and most powerful @@ -40,7 +40,7 @@ anything you like with it, such as modifying it, redistributing it, and selling it either in whole or in part. See the file `license.terms` for complete information. -## 2. Documentation +## 2. Documentation Extensive documentation is available at our website. The home page for this release, including new features, is [here](https://www.tcl.tk/software/tcltk/8.5.html). @@ -56,7 +56,7 @@ There have been many Tcl books on the market. Many are mentioned in The complete set of reference manual entries for Tcl 8.5 is [online, here](https://www.tcl-lang.org/man/tcl8.5/). -### 2a. Unix Documentation +### 2a. Unix Documentation The `doc` subdirectory in this release contains a complete set of reference manual entries for Tcl. Files with extension "`.1`" are for programs (for example, `tclsh.1`); files with extension "`.3`" are for C @@ -74,20 +74,20 @@ normal "man" mechanisms, such as man Tcl -### 2b. Windows Documentation +### 2b. Windows Documentation The "doc" subdirectory in this release contains a complete set of Windows help files for Tcl. Once you install this Tcl release, a shortcut to the Windows help Tcl documentation will appear in the "Start" menu: Start | Programs | Tcl | Tcl Help -## 3. Compiling and installing Tcl +## 3. Compiling and installing Tcl There are brief notes in the `unix/README`, `win/README`, and `macosx/README` about compiling on these different platforms. There is additional information about building Tcl from sources [online](https://www.tcl-lang.org/doc/howto/compile.html). -## 4. Development tools +## 4. Development tools ActiveState produces a high quality set of commercial quality development tools that is available to accelerate your Tcl application development. Tcl Dev Kit builds on the earlier TclPro toolset and provides a debugger, @@ -96,13 +96,13 @@ more. More information can be found at http://www.ActiveState.com/Tcl -## 5. Tcl newsgroup +## 5. Tcl newsgroup There is a USENET news group, "`comp.lang.tcl`", intended for the exchange of information about Tcl, Tk, and related applications. The newsgroup is a great place to ask general information questions. For bug reports, please see the "Support and bug fixes" section below. -## 6. Tcl'ers Wiki +## 6. Tcl'ers Wiki There is a [wiki-based open community site](https://wiki.tcl-lang.org/) covering all aspects of Tcl/Tk. @@ -112,13 +112,13 @@ snippets, references to papers, books, and FAQs, as well as pointers to development tools, extensions, and applications. You can also recommend additional URLs by editing the wiki yourself. -## 7. Mailing lists +## 7. Mailing lists Several mailing lists are hosted at SourceForge to discuss development or use issues (like Macintosh and Windows topics). For more information and to subscribe, visit [here](https://sourceforge.net/projects/tcl/) and go to the Mailing Lists page. -## 8. Support and Training +## 8. Support and Training We are very interested in receiving bug reports, patches, and suggestions for improvements. We prefer that you send this information to us as tickets entered into [our issue tracker](https://core.tcl-lang.org/tcl/reportlist). @@ -138,11 +138,11 @@ newsgroup and will attempt to answer esoteric questions for which no one else is likely to know the answer. In addition, see the wiki for [links to other organizations](https://wiki.tcl-lang.org/training) that offer Tcl/Tk training. -## 9. Tracking Development +## 9. Tracking Development Tcl is developed in public. You can keep an eye on how Tcl is changing at [core.tcl-lang.org](https://core.tcl-lang.org/). -## 10. Thank You +## 10. Thank You We'd like to express our thanks to the Tcl community for all the helpful suggestions, bug reports, and patches we have received. Tcl/Tk has improved vastly and will continue to do so with your help. -- cgit v0.12 From 6efd8f71f2a7f42d036b4899461500a0ec69b1fa Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 20 Oct 2018 16:44:51 +0000 Subject: formatting tweak --- README.md | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/README.md b/README.md index cbc49f0..094a189 100644 --- a/README.md +++ b/README.md @@ -8,16 +8,16 @@ site](https://sourceforge.net/projects/tcl/files/Tcl/). [![Build Status](https://travis-ci.org/tcltk/tcl.svg?branch=core-8-5-branch)](https://travis-ci.org/tcltk/tcl) ## Contents - 1. Introduction - 2. Documentation - 3. Compiling and installing Tcl - 4. Development tools - 5. Tcl newsgroup - 6. The Tcler's Wiki - 7. Mailing lists - 8. Support and Training - 9. Tracking Development - 10. Thank You + 1. Introduction + 2. Documentation + 3. Compiling and installing Tcl + 4. Development tools + 5. Tcl newsgroup + 6. The Tcler's Wiki + 7. Mailing lists + 8. Support and Training + 9. Tracking Development + 10. Thank You ## 1. Introduction Tcl provides a powerful platform for creating integration applications that -- cgit v0.12 From 1caba8a761ad4d16139496bcbd931d91ed3931f7 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 20 Oct 2018 16:47:29 +0000 Subject: Add local links --- README.md | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/README.md b/README.md index 094a189..3c4440e 100644 --- a/README.md +++ b/README.md @@ -8,16 +8,16 @@ site](https://sourceforge.net/projects/tcl/files/Tcl/). [![Build Status](https://travis-ci.org/tcltk/tcl.svg?branch=core-8-5-branch)](https://travis-ci.org/tcltk/tcl) ## Contents - 1. Introduction - 2. Documentation - 3. Compiling and installing Tcl - 4. Development tools - 5. Tcl newsgroup - 6. The Tcler's Wiki - 7. Mailing lists - 8. Support and Training - 9. Tracking Development - 10. Thank You + 1. [Introduction](#intro) + 2. [Documentation](#doc) + 3. [Compiling and installing Tcl](#build) + 4. [Development tools](#devtools) + 5. [Tcl newsgroup](#complangtcl) + 6. [The Tcler's Wiki](#wiki) + 7. [Mailing lists](#email) + 8. [Support and Training](#support) + 9. [Tracking Development](#watch) + 10. [Thank You](#thanks) ## 1. Introduction Tcl provides a powerful platform for creating integration applications that -- cgit v0.12 From 2e0a0b53053f3699f0593ca9e50b5ba45a548da1 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 20 Oct 2018 18:02:45 +0000 Subject: Remove old README --- README | 185 ----------------------------------------------------------------- 1 file changed, 185 deletions(-) delete mode 100644 README diff --git a/README b/README deleted file mode 100644 index c71d177..0000000 --- a/README +++ /dev/null @@ -1,185 +0,0 @@ -README: Tcl - This is the Tcl 8.5.19 source distribution. - http://sourceforge.net/projects/tcl/files/Tcl/ - You can get any source release of Tcl from the URL above. - -Contents --------- - 1. Introduction - 2. Documentation - 3. Compiling and installing Tcl - 4. Development tools - 5. Tcl newsgroup - 6. The Tcler's Wiki - 7. Mailing lists - 8. Support and Training - 9. Tracking Development - 10. Thank You - -1. Introduction ---------------- -Tcl provides a powerful platform for creating integration applications that -tie together diverse applications, protocols, devices, and frameworks. -When paired with the Tk toolkit, Tcl provides the fastest and most powerful -way to create GUI applications that run on PCs, Unix, and Mac OS X. -Tcl can also be used for a variety of web-related tasks and for creating -powerful command languages for applications. - -Tcl is maintained, enhanced, and distributed freely by the Tcl community. -Source code development and tracking of bug reports and feature requests -takes place at: - - http://core.tcl.tk/ - -Tcl/Tk release and mailing list services are hosted by SourceForge: - - http://sourceforge.net/projects/tcl/ - -with the Tcl Developer Xchange hosted at: - - http://www.tcl.tk/ - -Tcl is a freely available open source package. You can do virtually -anything you like with it, such as modifying it, redistributing it, -and selling it either in whole or in part. See the file -"license.terms" for complete information. - -2. Documentation ----------------- - -Extensive documentation is available at our website. -The home page for this release, including new features, is - http://www.tcl.tk/software/tcltk/8.5.html - -Detailed release notes can be found at the file distributions page -by clicking on the relevant version. - http://sourceforge.net/projects/tcl/files/Tcl/ - -Information about Tcl itself can be found at - http://www.tcl.tk/about/ - -There have been many Tcl books on the market. Many are mentioned in the Wiki: - http://wiki.tcl.tk/_/ref?N=25206 - -To view the complete set of reference manual entries for Tcl 8.5 online, -visit the URL: - http://www.tcl.tk/man/tcl8.5/ - -2a. Unix Documentation ----------------------- - -The "doc" subdirectory in this release contains a complete set of -reference manual entries for Tcl. Files with extension ".1" are for -programs (for example, tclsh.1); files with extension ".3" are for C -library procedures; and files with extension ".n" describe Tcl -commands. The file "doc/Tcl.n" gives a quick summary of the Tcl -language syntax. To print any of the man pages on Unix, cd to the -"doc" directory and invoke your favorite variant of troff using the -normal -man macros, for example - - ditroff -man Tcl.n - -to print Tcl.n. If Tcl has been installed correctly and your "man" program -supports it, you should be able to access the Tcl manual entries using the -normal "man" mechanisms, such as - - man Tcl - -2b. Windows Documentation -------------------------- - -The "doc" subdirectory in this release contains a complete set of Windows -help files for Tcl. Once you install this Tcl release, a shortcut to the -Windows help Tcl documentation will appear in the "Start" menu: - - Start | Programs | Tcl | Tcl Help - -3. Compiling and installing Tcl -------------------------------- - -There are brief notes in the unix/README, win/README, and macosx/README about -compiling on these different platforms. There is additional information -about building Tcl from sources at - - http://www.tcl.tk/doc/howto/compile.html - -4. Development tools ---------------------------- - -ActiveState produces a high quality set of commercial quality development -tools that is available to accelerate your Tcl application development. -Tcl Dev Kit builds on the earlier TclPro toolset and provides a debugger, -static code checker, single-file wrapping utility, bytecode compiler and -more. More information can be found at - - http://www.ActiveState.com/Tcl - -5. Tcl newsgroup ----------------- - -There is a USENET news group, "comp.lang.tcl", intended for the exchange of -information about Tcl, Tk, and related applications. The newsgroup is a -great place to ask general information questions. For bug reports, please -see the "Support and bug fixes" section below. - -6. Tcl'ers Wiki ---------------- - -A Wiki-based open community site covering all aspects of Tcl/Tk is at: - - http://wiki.tcl.tk/ - -It is dedicated to the Tcl programming language and its extensions. A -wealth of useful information can be found there. It contains code -snippets, references to papers, books, and FAQs, as well as pointers to -development tools, extensions, and applications. You can also recommend -additional URLs by editing the wiki yourself. - -7. Mailing lists ----------------- - -Several mailing lists are hosted at SourceForge to discuss development or -use issues (like Macintosh and Windows topics). For more information and -to subscribe, visit: - - http://sourceforge.net/projects/tcl/ - -and go to the Mailing Lists page. - -8. Support and Training ------------------------- - -We are very interested in receiving bug reports, patches, and suggestions -for improvements. We prefer that you send this information to us as -tickets entered into our tracker at: - - http://core.tcl.tk/tcl/reportlist - -We will log and follow-up on each bug, although we cannot promise a -specific turn-around time. Enhancements may take longer and may not happen -at all unless there is widespread support for them (we're trying to -slow the rate at which Tcl/Tk turns into a kitchen sink). It's very -difficult to make incompatible changes to Tcl/Tk at this point, due to -the size of the installed base. - -The Tcl community is too large for us to provide much individual support -for users. If you need help we suggest that you post questions to -comp.lang.tcl. We read the newsgroup and will attempt to answer esoteric -questions for which no one else is likely to know the answer. In addition, -see the following Web site for links to other organizations that offer -Tcl/Tk training: - - http://wiki.tcl.tk/training - -9. Tracking Development ------------------------ - -Tcl is developed in public. To keep an eye on how Tcl is changing, see - http://core.tcl.tk/ - -10. Thank You -------------- - -We'd like to express our thanks to the Tcl community for all the -helpful suggestions, bug reports, and patches we have received. -Tcl/Tk has improved vastly and will continue to do so with your help. -- cgit v0.12 From 9b417d4592f2b4b1640d0877d27345928e4210a7 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 20 Oct 2018 23:41:32 +0000 Subject: Rebase on 8.7 --- doc/define.n | 17 +++++++++++++---- generic/tclOODefineCmds.c | 27 +++++++++++++++++++++------ tests/oo.test | 20 ++++++++++++++++++-- 3 files changed, 52 insertions(+), 12 deletions(-) diff --git a/doc/define.n b/doc/define.n index 883d5fa..4e99b9a 100644 --- a/doc/define.n +++ b/doc/define.n @@ -140,7 +140,7 @@ where the current namespace is the instance namespace of the class object itself. This is useful for setting up, e.g., class-scoped variables. .VE TIP478 .TP -\fBmethod\fI name argList bodyScript\fR +\fBmethod\fI name \fR?\fIoption\fR? \fIargList bodyScript\fR . This creates or updates a method that is implemented as a procedure-like script. The name of the method is \fIname\fR, the formal arguments to the @@ -150,7 +150,11 @@ the body of the method is evaluated, the current namespace of the method will be a namespace that is unique to the current object. The method will be exported if \fIname\fR starts with a lower-case letter, and non-exported otherwise; this behavior can be overridden via \fBexport\fR and -\fBunexport\fR. +\fBunexport\fR +.VS TIP519 +or by specifying \fB\-export\fR or \fB\-unexport\fR in the optional parameter +\fIoption\fR. +.VE TIP519 .RS .PP .VS TIP500 @@ -321,7 +325,7 @@ below), this command creates private forwarded methods. .VE TIP500 .RE .TP -\fBmethod\fI name argList bodyScript\fR +\fBmethod\fI name \fR?\fIoption\fR? \fIargList bodyScript\fR . This creates, updates or deletes an object method. The name of the method is \fIname\fR, the formal arguments to the method (defined using the same format @@ -329,7 +333,12 @@ as for the Tcl \fBproc\fR command) will be \fIargList\fR, and the body of the method will be \fIbodyScript\fR. When the body of the method is evaluated, the current namespace of the method will be a namespace that is unique to the object. The method will be exported if \fIname\fR starts with a lower-case -letter, and non-exported otherwise. +letter, and non-exported otherwise; +.VS TIP519 +this can be overridden by specifying \fB\-export\fR or \fB\-unexport\fR in the +optional parameter \fIoption\fR, or via the \fBexport\fR and \fBunexport\fR +definitions. +.VE TIP519 .RS .PP .VS TIP500 diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index b4ff283..c056c26 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -1834,11 +1834,25 @@ TclOODefineMethodObjCmd( int isInstanceMethod = (clientData != NULL); Object *oPtr; int isPublic; + const char *exportMode = NULL; + size_t exportLen; - if (objc != 4) { - Tcl_WrongNumArgs(interp, 1, objv, "name args body"); + if (objc < 4 || objc > 5) { + Tcl_WrongNumArgs(interp, 1, objv, "name ?option? args body"); return TCL_ERROR; } + + if (objc == 5) { + exportMode = TclGetStringFromObj(objv[2], &exportLen); + if (exportLen == 0 || + (strcmp(exportMode, "-export") && + strcmp(exportMode, "-unexport"))) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "invalid export flag", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "INVALID_EXPORT_FLAG", NULL); + return TCL_ERROR; + } + } oPtr = (Object *) TclOOGetDefineCmdContext(interp); if (oPtr == NULL) { @@ -1850,8 +1864,9 @@ TclOODefineMethodObjCmd( Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; } - isPublic = Tcl_StringMatch(TclGetString(objv[1]), "[a-z]*") - ? PUBLIC_METHOD : 0; + isPublic = exportMode == NULL + ? Tcl_StringMatch(TclGetString(objv[1]), "[a-z]*") ? PUBLIC_METHOD : 0 + : exportMode[1] == 'e' ? PUBLIC_METHOD : 0; if (IsPrivateDefine(interp)) { isPublic = TRUE_PRIVATE_METHOD; } @@ -1862,12 +1877,12 @@ TclOODefineMethodObjCmd( if (isInstanceMethod) { if (TclOONewProcInstanceMethod(interp, oPtr, isPublic, objv[1], - objv[2], objv[3], NULL) == NULL) { + objv[objc - 2], objv[objc - 1], NULL) == NULL) { return TCL_ERROR; } } else { if (TclOONewProcMethod(interp, oPtr->classPtr, isPublic, objv[1], - objv[2], objv[3], NULL) == NULL) { + objv[objc - 2], objv[objc - 1], NULL) == NULL) { return TCL_ERROR; } } diff --git a/tests/oo.test b/tests/oo.test index 37c4495..4f5e65b 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -129,11 +129,11 @@ test oo-1.1 {basic test of OO functionality: no classes} { } {::foo {} a b c 3 {} {}} test oo-1.2 {basic test of OO functionality: no classes} -body { oo::define oo::object method missingArgs -} -returnCodes 1 -result "wrong # args: should be \"oo::define oo::object method name args body\"" +} -returnCodes 1 -result "wrong # args: should be \"oo::define oo::object method name ?option? args body\"" test oo-1.3 {basic test of OO functionality: no classes} { catch {oo::define oo::object method missingArgs} set errorInfo -} "wrong # args: should be \"oo::define oo::object method name args body\" +} "wrong # args: should be \"oo::define oo::object method name ?option? args body\" while executing \"oo::define oo::object method missingArgs\"" test oo-1.4 {basic test of OO functionality} -body { @@ -778,6 +778,22 @@ test oo-4.6 {export creates proper method entries} -setup { } -cleanup { testClass destroy } -result ok +test oo-4.7 {basic test of OO functionality: -export flag} { + set o [oo::object new] + set result {} + oo::objdefine $o method Foo {} {lappend ::result Foo; return} + lappend result [catch {$o Foo} msg] $msg + oo::objdefine $o method Bar -export {} {lappend ::result Bar; return} + lappend result [$o Bar] [$o destroy] +} {1 {unknown method "Foo": must be destroy} Bar {} {}} +test oo-4.8 {basic test of OO functionality: -unexport flag} { + set o [oo::object new] + set result {} + oo::objdefine $o method foo {} {lappend ::result foo; return} + lappend result [$o foo] + oo::objdefine $o method bar -unexport {} {lappend ::result bar; return} + lappend result [catch {$o bar} msg] $msg [$o destroy] +} {foo {} 1 {unknown method "bar": must be destroy or foo} {}} test oo-5.1 {OO: manipulation of classes as objects} -setup { set obj [oo::object new] -- cgit v0.12 From 775ce545d2f9d37cb91b7e251ab708db97dab440 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 21 Oct 2018 09:57:43 +0000 Subject: More tests. Better implementation. --- doc/define.n | 16 +++++----- generic/tclOODefineCmds.c | 57 +++++++++++++++++++++++----------- tests/oo.test | 78 +++++++++++++++++++++++++++++++++++++++-------- 3 files changed, 114 insertions(+), 37 deletions(-) diff --git a/doc/define.n b/doc/define.n index 4e99b9a..8cab8d3 100644 --- a/doc/define.n +++ b/doc/define.n @@ -152,14 +152,15 @@ exported if \fIname\fR starts with a lower-case letter, and non-exported otherwise; this behavior can be overridden via \fBexport\fR and \fBunexport\fR .VS TIP519 -or by specifying \fB\-export\fR or \fB\-unexport\fR in the optional parameter -\fIoption\fR. +or by specifying \fB\-export\fR, \fB\-private\fR or \fB\-unexport\fR in the +optional parameter \fIoption\fR. .VE TIP519 .RS .PP .VS TIP500 If in a private definition context (see the \fBprivate\fR definition command, -below), this command creates private procedure-like methods. +below) or if the \fB\-private\fR flag is given for \fIoption\fR, this command +creates private procedure-like methods. .VE TIP500 .RE .TP @@ -335,15 +336,16 @@ current namespace of the method will be a namespace that is unique to the object. The method will be exported if \fIname\fR starts with a lower-case letter, and non-exported otherwise; .VS TIP519 -this can be overridden by specifying \fB\-export\fR or \fB\-unexport\fR in the -optional parameter \fIoption\fR, or via the \fBexport\fR and \fBunexport\fR -definitions. +this can be overridden by specifying \fB\-export\fR, \fB\-private\fR or +\fB\-unexport\fR in the optional parameter \fIoption\fR, or via the +\fBexport\fR and \fBunexport\fR definitions. .VE TIP519 .RS .PP .VS TIP500 If in a private definition context (see the \fBprivate\fR definition command, -below), this command creates private procedure-like methods. +below) or if the \fB\-private\fR flag is given for \fIoption\fR, this command +creates private procedure-like methods. .VE TIP500 .RE .TP diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index c056c26..1062579 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -1831,10 +1831,25 @@ TclOODefineMethodObjCmd( int objc, Tcl_Obj *const *objv) { + /* + * Table of export modes for methods and their corresponding enum. + */ + + static const char *const exportModes[] = { + "-export", + "-private", + "-unexport", + NULL + }; + enum ExportMode { + MODE_EXPORT, + MODE_PRIVATE, + MODE_UNEXPORT + } exportMode; + int isInstanceMethod = (clientData != NULL); Object *oPtr; int isPublic; - const char *exportMode = NULL; size_t exportLen; if (objc < 4 || objc > 5) { @@ -1842,18 +1857,6 @@ TclOODefineMethodObjCmd( return TCL_ERROR; } - if (objc == 5) { - exportMode = TclGetStringFromObj(objv[2], &exportLen); - if (exportLen == 0 || - (strcmp(exportMode, "-export") && - strcmp(exportMode, "-unexport"))) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "invalid export flag", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "INVALID_EXPORT_FLAG", NULL); - return TCL_ERROR; - } - } - oPtr = (Object *) TclOOGetDefineCmdContext(interp); if (oPtr == NULL) { return TCL_ERROR; @@ -1864,11 +1867,29 @@ TclOODefineMethodObjCmd( Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; } - isPublic = exportMode == NULL - ? Tcl_StringMatch(TclGetString(objv[1]), "[a-z]*") ? PUBLIC_METHOD : 0 - : exportMode[1] == 'e' ? PUBLIC_METHOD : 0; - if (IsPrivateDefine(interp)) { - isPublic = TRUE_PRIVATE_METHOD; + if (objc == 5) { + if (Tcl_GetIndexFromObj(interp, objv[2], exportModes, "export flag", + 0, (int *) &exportMode) != TCL_OK) { + return TCL_ERROR; + } + switch (exportMode) { + case MODE_EXPORT: + isPublic = PUBLIC_METHOD; + break; + case MODE_PRIVATE: + isPublic = TRUE_PRIVATE_METHOD; + break; + case MODE_UNEXPORT: + isPublic = 0; + break; + } + } else { + if (IsPrivateDefine(interp)) { + isPublic = TRUE_PRIVATE_METHOD; + } else { + isPublic = Tcl_StringMatch(TclGetString(objv[1]), "[a-z]*") + ? PUBLIC_METHOD : 0; + } } /* diff --git a/tests/oo.test b/tests/oo.test index 4f5e65b..3974a76 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -778,22 +778,76 @@ test oo-4.6 {export creates proper method entries} -setup { } -cleanup { testClass destroy } -result ok -test oo-4.7 {basic test of OO functionality: -export flag} { +test oo-4.7 {basic test of OO functionality: method -export flag} -setup { set o [oo::object new] - set result {} - oo::objdefine $o method Foo {} {lappend ::result Foo; return} + unset -nocomplain result +} -body { + oo::objdefine $o { + method Foo {} { + lappend ::result Foo + return foo + } + method Bar -export {} { + lappend ::result Bar + return bar + } + } lappend result [catch {$o Foo} msg] $msg - oo::objdefine $o method Bar -export {} {lappend ::result Bar; return} - lappend result [$o Bar] [$o destroy] -} {1 {unknown method "Foo": must be destroy} Bar {} {}} -test oo-4.8 {basic test of OO functionality: -unexport flag} { + lappend result [$o Bar] +} -cleanup { + $o destroy +} -result {1 {unknown method "Foo": must be Bar or destroy} Bar bar} +test oo-4.8 {basic test of OO functionality: method -unexport flag} -setup { set o [oo::object new] - set result {} - oo::objdefine $o method foo {} {lappend ::result foo; return} + unset -nocomplain result +} -body { + oo::objdefine $o { + method foo {} { + lappend ::result foo + return Foo + } + method bar -unexport {} { + lappend ::result bar + return Bar + } + } + lappend result [$o foo] + lappend result [catch {$o bar} msg] $msg +} -cleanup { + $o destroy +} -result {foo Foo 1 {unknown method "bar": must be destroy or foo}} +test oo-4.9 {basic test of OO functionality: method -private flag} -setup { + set o [oo::object new] + unset -nocomplain result +} -body { + oo::objdefine $o { + method foo {} { + lappend ::result foo + return Foo + } + method bar -private {} { + lappend ::result bar + return Bar + } + export eval + method gorp {} { + my bar + } + } lappend result [$o foo] - oo::objdefine $o method bar -unexport {} {lappend ::result bar; return} - lappend result [catch {$o bar} msg] $msg [$o destroy] -} {foo {} 1 {unknown method "bar": must be destroy or foo} {}} + lappend result [catch {$o bar} msg] $msg + lappend result [catch {$o eval my bar} msg] $msg + lappend result [$o gorp] +} -cleanup { + $o destroy +} -result {foo Foo 1 {unknown method "bar": must be destroy, eval, foo or gorp} 1 {unknown method "bar": must be , destroy, eval, foo, gorp, unknown, variable or varname} bar Bar} +test oo-4.10 {basic test of OO functionality: method flag parsing} -setup { + set o [oo::object new] +} -body { + oo::objdefine $o method foo -gorp xyz {return Foo} +} -returnCodes error -cleanup { + $o destroy +} -result {bad export flag "-gorp": must be -export, -private, or -unexport} test oo-5.1 {OO: manipulation of classes as objects} -setup { set obj [oo::object new] -- cgit v0.12 From 37c458acb73d94fa74e19dd036a751a54b5756e1 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 21 Oct 2018 10:01:04 +0000 Subject: Remove unused variable --- generic/tclOODefineCmds.c | 1 - 1 file changed, 1 deletion(-) diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index 1062579..9455dd6 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -1850,7 +1850,6 @@ TclOODefineMethodObjCmd( int isInstanceMethod = (clientData != NULL); Object *oPtr; int isPublic; - size_t exportLen; if (objc < 4 || objc > 5) { Tcl_WrongNumArgs(interp, 1, objv, "name ?option? args body"); -- cgit v0.12 From 0c78f5bbada0703c8063287e2e063604c4023ba7 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 21 Oct 2018 10:16:05 +0000 Subject: Disable windows builds. Make test failures fatal. --- .travis.yml | 12 +++++++----- library/tcltest/tcltest.tcl | 4 ++-- tests/all.tcl | 4 +++- 3 files changed, 12 insertions(+), 8 deletions(-) diff --git a/.travis.yml b/.travis.yml index 3abeb6b..d5c93c1 100644 --- a/.travis.yml +++ b/.travis.yml @@ -48,16 +48,18 @@ matrix: - os: osx osx_image: xcode8 env: - - MATRIX_EVAL="BUILD_DIR=macosx" - - os: windows - env: - - MATRIX_EVAL="BUILD_DIR=win" + - MATRIX_EVAL="BUILD_DIR=macosx && NO_DIRECT_CONFIGURE=1" +### C builds not currently supported on Windows instances +# - os: windows +# env: +# - MATRIX_EVAL="BUILD_DIR=win" before_install: - eval "${MATRIX_EVAL}" + - export ERROR_ON_FAILURES=1 - cd ${BUILD_DIR} install: - - ./configure + - test -z "$NO_DIRECT_CONFIGURE" || ./configure script: - make - make test diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index 8e43859..0d55ff7 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -2696,7 +2696,7 @@ proc tcltest::GetMatchingDirectories {rootdir} { # shell being tested # # Results: -# None. +# Whether there were any failures. # # Side effects: # None. @@ -2842,7 +2842,7 @@ proc tcltest::runAllTests { {shell ""} } { puts [outputChannel] "" puts [outputChannel] [string repeat ~ 44] } - return + return [info exists testFileFailures] } ##################################################################### diff --git a/tests/all.tcl b/tests/all.tcl index d01a54d..f3463c6 100644 --- a/tests/all.tcl +++ b/tests/all.tcl @@ -14,4 +14,6 @@ package require Tcl 8.5 package require tcltest 2.2 namespace import tcltest::* configure {*}$argv -testdir [file dir [info script]] -runAllTests +set ErrorOnFailures [info exists env(ERROR_ON_FAILURES)] +unset -nocomplain env(ERROR_ON_FAILURES) +if {[runAllTests] && $ErrorOnFailures} {exit 1} -- cgit v0.12 From 8c05c20df453400c69cdcddd621fd9fc7e692e73 Mon Sep 17 00:00:00 2001 From: pspjuth Date: Mon, 22 Oct 2018 05:56:37 +0000 Subject: Implement TIP 522, Test error codes with Tcltest --- library/tcltest/tcltest.tcl | 38 ++++++++++++++++++++++++++++---------- 1 file changed, 28 insertions(+), 10 deletions(-) diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index f1b6082..a4954e7 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -1841,6 +1841,9 @@ proc tcltest::SubstArguments {argList} { # is optional; default is {}. # returnCodes - Expected return codes. This attribute is # optional; default is {0 2}. +# errorCode - Expected error code. This attribute is +# optional; default is {}. It is a glob pattern. +# If given, returnCodes defaults to {1}. # setup - Code to run before $script (above). This # attribute is optional; default is {}. # cleanup - Code to run after $script (above). This @@ -1882,7 +1885,7 @@ proc tcltest::test {name description args} { # Pre-define everything to null except output and errorOutput. We # determine whether or not to trap output based on whether or not # these variables (output & errorOutput) are defined. - lassign {} constraints setup cleanup body result returnCodes match + lassign {} constraints setup cleanup body result returnCodes errorCode match # Set the default match mode set match exact @@ -1901,7 +1904,7 @@ proc tcltest::test {name description args} { set testAttributes($element) $value } foreach item {constraints match setup body cleanup \ - result returnCodes output errorOutput} { + result returnCodes errorCode output errorOutput} { if {[info exists testAttributes(-$item)]} { set testAttributes(-$item) [uplevel 1 \ ::concat $testAttributes(-$item)] @@ -1912,7 +1915,7 @@ proc tcltest::test {name description args} { } set validFlags {-setup -cleanup -body -result -returnCodes \ - -match -output -errorOutput -constraints} + -errorCode -match -output -errorOutput -constraints} foreach flag [array names testAttributes] { if {$flag ni $validFlags} { @@ -1944,6 +1947,10 @@ proc tcltest::test {name description args} { foreach {strcode numcode} {ok 0 normal 0 error 1 return 2 break 3 continue 4} { set returnCodes [string map -nocase [list $strcode $numcode] $returnCodes] } + # errorCode without returnCode 1 is meaningless + if {$errorCode ne "" && 1 ni $returnCodes} { + set returnCodes 1 + } } else { # This is parsing for the old test command format; it is here # for backward compatibility. @@ -1976,7 +1983,7 @@ proc tcltest::test {name description args} { set code [catch {uplevel 1 $setup} setupMsg] if {$code == 1} { set errorInfo(setup) $::errorInfo - set errorCode(setup) $::errorCode + set errorCodeRes(setup) $::errorCode } set setupFailure [expr {$code != 0}] @@ -2003,7 +2010,7 @@ proc tcltest::test {name description args} { lassign $testResult actualAnswer returnCode if {$returnCode == 1} { set errorInfo(body) $::errorInfo - set errorCode(body) $::errorCode + set errorCodeRes(body) $::errorCode } } @@ -2012,6 +2019,13 @@ proc tcltest::test {name description args} { if {!$setupFailure && ($returnCode ni $returnCodes)} { set codeFailure 1 } + set errCodeFailure 0 + if {!$setupFailure && !$codeFailure && $returnCode == 1 && \ + $errorCode ne "" && \ + ![string match $errorCode $errorCodeRes(body)]} { + set codeFailure 1 + set errCodeFailure 1 + } # If expected output/error strings exist, we have to compare # them. If the comparison fails, then so did the test. @@ -2055,7 +2069,7 @@ proc tcltest::test {name description args} { set code [catch {uplevel 1 $cleanup} cleanupMsg] if {$code == 1} { set errorInfo(cleanup) $::errorInfo - set errorCode(cleanup) $::errorCode + set errorCodeRes(cleanup) $::errorCode } set cleanupFailure [expr {$code != 0}] @@ -2159,7 +2173,7 @@ proc tcltest::test {name description args} { failed:\n$setupMsg" if {[info exists errorInfo(setup)]} { puts [outputChannel] "---- errorInfo(setup): $errorInfo(setup)" - puts [outputChannel] "---- errorCode(setup): $errorCode(setup)" + puts [outputChannel] "---- errorCode(setup): $errorCodeRes(setup)" } } if {$scriptFailure} { @@ -2171,7 +2185,11 @@ proc tcltest::test {name description args} { ($match matching):\n$result" } } - if {$codeFailure} { + if {$errCodeFailure} { + # TODO + puts [outputChannel] "---- Error code was: '$errorCodeRes(body)'" + puts [outputChannel] "---- Error code should have been: '$errorCode'" + } elseif {$codeFailure} { switch -- $returnCode { 0 { set msg "Test completed normally" } 1 { set msg "Test generated error" } @@ -2186,7 +2204,7 @@ proc tcltest::test {name description args} { if {[IsVerbose error]} { if {[info exists errorInfo(body)] && (1 ni $returnCodes)} { puts [outputChannel] "---- errorInfo: $errorInfo(body)" - puts [outputChannel] "---- errorCode: $errorCode(body)" + puts [outputChannel] "---- errorCode: $errorCodeRes(body)" } } } @@ -2212,7 +2230,7 @@ proc tcltest::test {name description args} { puts [outputChannel] "---- Test cleanup failed:\n$cleanupMsg" if {[info exists errorInfo(cleanup)]} { puts [outputChannel] "---- errorInfo(cleanup): $errorInfo(cleanup)" - puts [outputChannel] "---- errorCode(cleanup): $errorCode(cleanup)" + puts [outputChannel] "---- errorCode(cleanup): $errorCodeRes(cleanup)" } } if {$coreFailure} { -- cgit v0.12 From c201290179fd33b699c27e7ed181281c18a8fa06 Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 22 Oct 2018 13:11:45 +0000 Subject: Expand the build matrix --- .travis.yml | 44 +++++++++++++++++++++++++++++++++++--------- 1 file changed, 35 insertions(+), 9 deletions(-) diff --git a/.travis.yml b/.travis.yml index d5c93c1..0f8af5a 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,11 +1,26 @@ dist: trusty +sudo: false language: c matrix: include: - os: linux + compiler: clang env: - - MATRIX_EVAL="BUILD_DIR=unix" + - MATRIX_EVAL="" BUILD_DIR=unix - os: linux + compiler: clang + env: + - MATRIX_EVAL="" BUILD_DIR=unix CFGOPT=--disable-shared + - os: linux + compiler: gcc + env: + - MATRIX_EVAL="" BUILD_DIR=unix + - os: linux + compiler: gcc + env: + - MATRIX_EVAL="" BUILD_DIR=unix CFGOPT=--disable-shared + - os: linux + compiler: gcc addons: apt: sources: @@ -13,8 +28,9 @@ matrix: packages: - g++-4.9 env: - - MATRIX_EVAL="CC=gcc-4.9 && BUILD_DIR=unix" + - MATRIX_EVAL="CC=gcc-4.9" BUILD_DIR=unix - os: linux + compiler: gcc addons: apt: sources: @@ -22,8 +38,9 @@ matrix: packages: - g++-5 env: - - MATRIX_EVAL="CC=gcc-5 && BUILD_DIR=unix" + - MATRIX_EVAL="CC=gcc-5" BUILD_DIR=unix - os: linux + compiler: gcc addons: apt: sources: @@ -31,8 +48,9 @@ matrix: packages: - g++-6 env: - - MATRIX_EVAL="CC=gcc-6 && BUILD_DIR=unix" + - MATRIX_EVAL="CC=gcc-6" BUILD_DIR=unix - os: linux + compiler: gcc addons: apt: sources: @@ -40,26 +58,34 @@ matrix: packages: - g++-7 env: - - MATRIX_EVAL="CC=gcc-7 && BUILD_DIR=unix" + - MATRIX_EVAL="CC=gcc-7" BUILD_DIR=unix - os: osx osx_image: xcode8 env: - - MATRIX_EVAL="BUILD_DIR=unix" + - MATRIX_EVAL="" BUILD_DIR=unix - os: osx osx_image: xcode8 env: - - MATRIX_EVAL="BUILD_DIR=macosx && NO_DIRECT_CONFIGURE=1" + - MATRIX_EVAL="" BUILD_DIR=macosx NO_DIRECT_CONFIGURE=1 + - os: osx + osx_image: xcode9 + env: + - MATRIX_EVAL="" BUILD_DIR=macosx NO_DIRECT_CONFIGURE=1 + - os: osx + osx_image: xcode10 + env: + - MATRIX_EVAL="" BUILD_DIR=macosx NO_DIRECT_CONFIGURE=1 ### C builds not currently supported on Windows instances # - os: windows # env: -# - MATRIX_EVAL="BUILD_DIR=win" +# - MATRIX_EVAL="" BUILD_DIR=win before_install: - eval "${MATRIX_EVAL}" - export ERROR_ON_FAILURES=1 - cd ${BUILD_DIR} install: - - test -z "$NO_DIRECT_CONFIGURE" || ./configure + - test -n "$NO_DIRECT_CONFIGURE" || ./configure ${CFGOPT} script: - make - make test -- cgit v0.12 From 36f2cb4d7dbd7c8008161479f97985026e060e9e Mon Sep 17 00:00:00 2001 From: pspjuth Date: Mon, 22 Oct 2018 18:43:47 +0000 Subject: Implement TIP 523, New lpop command --- generic/tclBasic.c | 1 + generic/tclCmdIL.c | 97 ++++++++++++++++++++++++++++++++++++ generic/tclInt.h | 3 ++ generic/tclListObj.c | 26 ++++++++-- tests/lpop.test | 136 +++++++++++++++++++++++++++++++++++++++++++++++++++ 5 files changed, 258 insertions(+), 5 deletions(-) create mode 100644 tests/lpop.test diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 179306d..3a133d3 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -260,6 +260,7 @@ static const CmdInfo builtInCmds[] = { {"list", Tcl_ListObjCmd, TclCompileListCmd, NULL, CMD_IS_SAFE|CMD_COMPILES_EXPANDED}, {"llength", Tcl_LlengthObjCmd, TclCompileLlengthCmd, NULL, CMD_IS_SAFE}, {"lmap", Tcl_LmapObjCmd, TclCompileLmapCmd, TclNRLmapCmd, CMD_IS_SAFE}, + {"lpop", Tcl_LpopObjCmd, NULL, NULL, CMD_IS_SAFE}, {"lrange", Tcl_LrangeObjCmd, TclCompileLrangeCmd, NULL, CMD_IS_SAFE}, {"lrepeat", Tcl_LrepeatObjCmd, NULL, NULL, CMD_IS_SAFE}, {"lreplace", Tcl_LreplaceObjCmd, TclCompileLreplaceCmd, NULL, CMD_IS_SAFE}, diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 434840e..fb19a3f 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -2571,6 +2571,103 @@ Tcl_LlengthObjCmd( /* *---------------------------------------------------------------------- * + * Tcl_LpopObjCmd -- + * + * This procedure is invoked to process the "lpop" Tcl command. See the + * user documentation for details on what it does. + * + * Results: + * A standard Tcl object result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_LpopObjCmd( + ClientData notUsed, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + register Tcl_Obj *const objv[]) + /* Argument objects. */ +{ + int listLen, result; + Tcl_Obj *elemPtr; + Tcl_Obj *listPtr, **elemPtrs; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "listvar ?index?"); + return TCL_ERROR; + } + + listPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG); + if (listPtr == NULL) { + return TCL_ERROR; + } + + result = TclListObjGetElements(interp, listPtr, &listLen, &elemPtrs); + if (result != TCL_OK) { + return result; + } + + /* + * First, extract the element to be returned. + * TclLindex* adds a ref count which is handled. + */ + + if (objc == 2) { + elemPtr = elemPtrs[listLen - 1]; + Tcl_IncrRefCount(elemPtr); + } else { + if (objc == 3) { + elemPtr = TclLindexList(interp, listPtr, objv[2]); + } else { + elemPtr = TclLindexFlat(interp, listPtr, objc-2, objv+2); + } + + if (elemPtr == NULL) { + return TCL_ERROR; + } + } + Tcl_SetObjResult(interp, elemPtr); + Tcl_DecrRefCount(elemPtr); + + /* + * Second, remove the element. + */ + + if (objc == 2) { + if (Tcl_IsShared(listPtr)) { + listPtr = TclListObjCopy(NULL, listPtr); + } + result = Tcl_ListObjReplace(interp, listPtr, listLen - 1, 1, 0, NULL); + if (result != TCL_OK) { + return result; + } + } else { + if (objc == 3) { + listPtr = TclLsetList(interp, listPtr, objv[2], NULL); + } else { + listPtr = TclLsetFlat(interp, listPtr, objc-2, objv+2, NULL); + } + if (listPtr == NULL) { + return TCL_ERROR; + } + } + + listPtr = Tcl_ObjSetVar2(interp, objv[1], NULL, listPtr, TCL_LEAVE_ERR_MSG); + if (listPtr == NULL) { + return TCL_ERROR; + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_LrangeObjCmd -- * * This procedure is invoked to process the "lrange" Tcl command. See the diff --git a/generic/tclInt.h b/generic/tclInt.h index abf6c83..04ed7af 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3452,6 +3452,9 @@ MODULE_SCOPE int Tcl_LmapObjCmd(ClientData clientData, MODULE_SCOPE int Tcl_LoadObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_LpopObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_LrangeObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 8314306..be05873 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -1356,6 +1356,7 @@ TclLindexFlat( * * Core of the 'lset' command when objc == 4. Objv[2] may be either a * scalar index or a list of indices. + * It also handles 'lpop' when given a NULL value. * * Results: * Returns the new value of the list variable, or NULL if there was an @@ -1380,7 +1381,7 @@ TclLsetList( Tcl_Interp *interp, /* Tcl interpreter. */ Tcl_Obj *listPtr, /* Pointer to the list being modified. */ Tcl_Obj *indexArgPtr, /* Index or index-list arg to 'lset'. */ - Tcl_Obj *valuePtr) /* Value arg to 'lset'. */ + Tcl_Obj *valuePtr) /* Value arg to 'lset' or NULL to 'lpop'. */ { int indexCount = 0; /* Number of indices in the index list. */ Tcl_Obj **indices = NULL; /* Vector of indices in the index list. */ @@ -1431,6 +1432,7 @@ TclLsetList( * TclLsetFlat -- * * Core engine of the 'lset' command. + * It also handles 'lpop' when given a NULL value. * * Results: * Returns the new value of the list variable, or NULL if an error @@ -1475,7 +1477,7 @@ TclLsetFlat( int indexCount, /* Number of index args. */ Tcl_Obj *const indexArray[], /* Index args. */ - Tcl_Obj *valuePtr) /* Value arg to 'lset'. */ + Tcl_Obj *valuePtr) /* Value arg to 'lset' or NULL to 'lpop'. */ { int index, result, len; Tcl_Obj *subListPtr, *retValuePtr, *chainPtr; @@ -1483,9 +1485,19 @@ TclLsetFlat( /* * If there are no indices, simply return the new value. (Without * indices, [lset] is a synonym for [set]. + * This is an error for [lpop]. */ if (indexCount == 0) { + if (valuePtr == NULL) { + if (interp != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("list index out of range", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LPOP", + "BADINDEX", NULL); + } + return NULL; + } Tcl_IncrRefCount(valuePtr); return valuePtr; } @@ -1546,12 +1558,14 @@ TclLsetFlat( } indexArray++; - if (index < 0 || index > elemCount) { + if (index < 0 || index > elemCount + || (valuePtr == NULL && index >= elemCount)) { /* ...the index points outside the sublist. */ if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj("list index out of range", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSET", + Tcl_SetErrorCode(interp, "TCL", "OPERATION", + valuePtr == NULL ? "LPOP" : "LSET", "BADINDEX", NULL); } result = TCL_ERROR; @@ -1661,7 +1675,9 @@ TclLsetFlat( len = -1; TclListObjLength(NULL, subListPtr, &len); - if (index == len) { + if (valuePtr == NULL) { + Tcl_ListObjReplace(NULL, subListPtr, index, 1, 0, NULL); + } else if (index == len) { Tcl_ListObjAppendElement(NULL, subListPtr, valuePtr); } else { TclListObjSetElement(NULL, subListPtr, index, valuePtr); diff --git a/tests/lpop.test b/tests/lpop.test new file mode 100644 index 0000000..7f0c6a8 --- /dev/null +++ b/tests/lpop.test @@ -0,0 +1,136 @@ +# Commands covered: lpop +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1991-1993 The Regents of the University of California. +# Copyright (c) 1994 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest + namespace import -force ::tcltest::* +} + +test lpop-1.1 {error conditions} -returnCodes error -body { + lpop no +} -result {can't read "no": no such variable} +test lpop-1.2 {error conditions} -returnCodes error -body { + lpop no 0 +} -result {can't read "no": no such variable} +test lpop-1.3 {error conditions} -returnCodes error -body { + set no "x {}x" + lpop no +} -result {list element in braces followed by "x" instead of space} +test lpop-1.4 {error conditions} -returnCodes error -body { + set no "x y" + lpop no -1 +} -result {list index out of range} +test lpop-1.5 {error conditions} -returnCodes error -body { + set no "x y z" + lpop no 3 +} -result {list index out of range} ;#-errorCode {TCL OPERATION LPOP BADINDEX} +test lpop-1.6 {error conditions} -returnCodes error -body { + set no "x y" + lpop no end+1 +} -result {list index out of range} +test lpop-1.7 {error conditions} -returnCodes error -body { + set no "x y" + lpop no {} +} -result {list index out of range} +test lpop-1.8 {error conditions} -returnCodes error -body { + set no "x y" + lpop no {0 0 0 0 1} +} -result {list index out of range} + +test lpop-2.1 {basic functionality} -body { + set l "x y z" + list [lpop l 0] $l +} -result {x {y z}} +test lpop-2.2 {basic functionality} -body { + set l "x y z" + list [lpop l 1] $l +} -result {y {x z}} +test lpop-2.3 {basic functionality} -body { + set l "x y z" + list [lpop l] $l +} -result {z {x y}} +test lpop-2.4 {basic functionality} -body { + set l "x y z" + set l2 $l + list [lpop l] $l $l2 +} -result {z {x y} {x y z}} + +test lpop-3.1 {nested} -body { + set l "x y" + set l2 $l + list [lpop l {0 0 0 0}] $l $l2 +} -result {x {{{{}}} y} {x y}} +test lpop-3.2 {nested} -body { + set l "{x y} {a b}" + list [lpop l {0 1}] $l +} -result {y {x {a b}}} +test lpop-3.3 {nested} -body { + set l "{x y} {a b}" + list [lpop l {1 0}] $l +} -result {a {{x y} b}} + + + + + +test lpop-99.1 {performance} -constraints perf -body { + set l [lrepeat 10000 x] + set l2 $l + set t1 [time { + while {[llength $l] >= 2} { + lpop l end + } + }] + set l [lrepeat 30000 x] + set l2 $l + set t2 [time { + while {[llength $l] >= 2} { + lpop l end + } + }] + regexp {\d+} $t1 ms1 + regexp {\d+} $t2 ms2 + set ratio [expr {double($ms2)/$ms1}] + # Deleting from end should have linear performance + expr {$ratio > 4 ? $ratio : 4} +} -result {4} + +test lpop-99.2 {performance} -constraints perf -body { + set l [lrepeat 10000 x] + set l2 $l + set t1 [time { + while {[llength $l] >= 2} { + lpop l 1 + } + }] + set l [lrepeat 30000 x] + set l2 $l + set t2 [time { + while {[llength $l] >= 2} { + lpop l 1 + } + }] + regexp {\d+} $t1 ms1 + regexp {\d+} $t2 ms2 + set ratio [expr {double($ms2)/$ms1}] + expr {$ratio > 10 ? $ratio : 10} +} -result {10} + + +# cleanup +::tcltest::cleanupTests +return + +# Local Variables: +# mode: tcl +# End: -- cgit v0.12 From 5b1614f31a3c2c510c726089b6ca499cfb792e72 Mon Sep 17 00:00:00 2001 From: pspjuth Date: Mon, 22 Oct 2018 20:27:03 +0000 Subject: Documentation and revision bump for tip 522 --- doc/tcltest.n | 14 ++++++++++++-- library/init.tcl | 2 +- library/tcltest/pkgIndex.tcl | 2 +- library/tcltest/tcltest.tcl | 10 ++++++---- unix/Makefile.in | 4 ++-- 5 files changed, 22 insertions(+), 10 deletions(-) diff --git a/doc/tcltest.n b/doc/tcltest.n index 05c1922..b161a2b 100644 --- a/doc/tcltest.n +++ b/doc/tcltest.n @@ -8,7 +8,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.TH "tcltest" n 2.3 tcltest "Tcl Bundled Packages" +.TH "tcltest" n 2.5 tcltest "Tcl Bundled Packages" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! @@ -16,7 +16,7 @@ tcltest \- Test harness support code and utilities .SH SYNOPSIS .nf -\fBpackage require tcltest\fR ?\fB2.3\fR? +\fBpackage require tcltest\fR ?\fB2.5\fR? \fBtcltest::test \fIname description\fR ?\fI\-option value ...\fR? \fBtcltest::test \fIname description\fR ?\fIconstraints\fR? \fIbody result\fR @@ -454,6 +454,7 @@ The valid options for \fBtest\fR are summarized: ?\fB\-output \fIexpectedOutput\fR? ?\fB\-errorOutput \fIexpectedError\fR? ?\fB\-returnCodes \fIcodeList\fR? + ?\fB\-errorCode \fIexpectedErrorCode\fR? ?\fB\-match \fImode\fR? .CE .PP @@ -577,6 +578,15 @@ return codes known to \fBreturn\fR, in both numeric and symbolic form, including extended return codes, are acceptable elements in the \fIexpectedCodeList\fR. Default value is .QW "\fBok return\fR" . +.TP +\fB\-errorCode \fIexpectedErrorCode\fR +. +The optional \fB\-errorCode\fR attribute supplies \fIexpectedErrorCode\fR, +a glob pattern that should match the error code reported from evaluation of the +\fB\-body\fR script. If evaluation of the \fB\-body\fR script returns +a code not matching \fIexpectedErrorCode\fR, the test fails. Default value is +.QW "\fB*\fR" . +If \fB\-returnCodes\fR does not include \fBerror\fR it is set to \fBerror\fR. .PP To pass, a test must successfully evaluate its \fB\-setup\fR, \fB\-body\fR, and \fB\-cleanup\fR scripts. The return code of the \fB\-body\fR script and diff --git a/library/init.tcl b/library/init.tcl index 51339d0..1221e61 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -810,7 +810,7 @@ foreach {safe package version file} { 1 opt 0.4.7 {opt optparse.tcl} 0 platform 1.0.14 {platform platform.tcl} 0 platform::shell 1.1.4 {platform shell.tcl} - 1 tcltest 2.4.1 {tcltest tcltest.tcl} + 1 tcltest 2.5.0 {tcltest tcltest.tcl} } { if {$isafe && !$safe} continue package ifneeded $package $version [list source [file join $dir {*}$file]] diff --git a/library/tcltest/pkgIndex.tcl b/library/tcltest/pkgIndex.tcl index eadb1bd..fde3ffe 100644 --- a/library/tcltest/pkgIndex.tcl +++ b/library/tcltest/pkgIndex.tcl @@ -9,4 +9,4 @@ # full path name of this file's directory. if {![package vsatisfies [package provide Tcl] 8.5-]} {return} -package ifneeded tcltest 2.4.1 [list source [file join $dir tcltest.tcl]] +package ifneeded tcltest 2.5.0 [list source [file join $dir tcltest.tcl]] diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index a4954e7..8b14142 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -22,7 +22,7 @@ namespace eval tcltest { # When the version number changes, be sure to update the pkgIndex.tcl file, # and the install directory in the Makefiles. When the minor version # changes (new feature) be sure to update the man page as well. - variable Version 2.4.1 + variable Version 2.5.0 # Compatibility support for dumb variables defined in tcltest 1 # Do not use these. Call [package provide Tcl] and [info patchlevel] @@ -1842,7 +1842,7 @@ proc tcltest::SubstArguments {argList} { # returnCodes - Expected return codes. This attribute is # optional; default is {0 2}. # errorCode - Expected error code. This attribute is -# optional; default is {}. It is a glob pattern. +# optional; default is {*}. It is a glob pattern. # If given, returnCodes defaults to {1}. # setup - Code to run before $script (above). This # attribute is optional; default is {}. @@ -1895,6 +1895,9 @@ proc tcltest::test {name description args} { # 'return' being used in the test script). set returnCodes [list 0 2] + # Set the default error code pattern + set errorCode "*" + # The old test format can't have a 3rd argument (constraints or # script) that starts with '-'. if {[string match -* [lindex $args 0]] || ([llength $args] <= 1)} { @@ -1948,7 +1951,7 @@ proc tcltest::test {name description args} { set returnCodes [string map -nocase [list $strcode $numcode] $returnCodes] } # errorCode without returnCode 1 is meaningless - if {$errorCode ne "" && 1 ni $returnCodes} { + if {$errorCode ne "*" && 1 ni $returnCodes} { set returnCodes 1 } } else { @@ -2021,7 +2024,6 @@ proc tcltest::test {name description args} { } set errCodeFailure 0 if {!$setupFailure && !$codeFailure && $returnCode == 1 && \ - $errorCode ne "" && \ ![string match $errorCode $errorCodeRes(body)]} { set codeFailure 1 set errCodeFailure 1 diff --git a/unix/Makefile.in b/unix/Makefile.in index 487ae61..c42abbf 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -933,9 +933,9 @@ install-libraries: libraries @echo "Installing package msgcat 1.7.0 as a Tcl Module" @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl \ "$(MODULE_INSTALL_DIR)"/tcl8/8.7/msgcat-1.7.0.tm - @echo "Installing package tcltest 2.4.1 as a Tcl Module" + @echo "Installing package tcltest 2.5.0 as a Tcl Module" @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl \ - "$(MODULE_INSTALL_DIR)"/tcl8/8.5/tcltest-2.4.1.tm + "$(MODULE_INSTALL_DIR)"/tcl8/8.5/tcltest-2.5.0.tm @echo "Installing package platform 1.0.14 as a Tcl Module" @$(INSTALL_DATA) $(TOP_DIR)/library/platform/platform.tcl \ "$(MODULE_INSTALL_DIR)"/tcl8/8.4/platform-1.0.14.tm -- cgit v0.12 From 394e22ef5d4e279dbb1e8d2d6616c84e70f5032f Mon Sep 17 00:00:00 2001 From: pspjuth Date: Mon, 22 Oct 2018 21:15:00 +0000 Subject: Updated tests to exercise new feature. --- tests/assemble.test | 11 ++++++----- tests/dict.test | 12 ++---------- tests/ioCmd.test | 4 ++-- tests/source.test | 7 +++---- tests/tcltest.test | 6 +++--- 5 files changed, 16 insertions(+), 24 deletions(-) diff --git a/tests/assemble.test b/tests/assemble.test index d7c47a9..bea780a 100644 --- a/tests/assemble.test +++ b/tests/assemble.test @@ -852,10 +852,11 @@ test assemble-8.5 {bad context} { -body { namespace eval assem { set x 1 - list [catch {assemble {load x}} result opts] $result [dict get $opts -errorcode] + assemble {load x} } } - -result {1 {cannot use this instruction to create a variable in a non-proc context} {TCL ASSEM LVT}} + -result {cannot use this instruction to create a variable in a non-proc context} + -errorCode {TCL ASSEM LVT} -cleanup {namespace delete assem} } test assemble-8.6 {load1} { @@ -1110,10 +1111,10 @@ test assemble-9.6 {concat} { } test assemble-9.7 {concat} { -body { - list [catch {assemble {concat 0}} result] $result $::errorCode + assemble {concat 0} } - -result {1 {operand must be positive} {TCL ASSEM POSITIVE}} - -cleanup {unset result} + -result {operand must be positive} + -errorCode {TCL ASSEM POSITIVE} } # assemble-10 -- eval and expr diff --git a/tests/dict.test b/tests/dict.test index a6b0cb4..1479727 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -175,11 +175,7 @@ test dict-4.12 {dict replace command: canonicality is forced} { } {a e c d} test dict-4.13 {dict replace command: type check is mandatory} -body { dict replace { a b c d e } -} -returnCodes error -result {missing value to go with key} -test dict-4.13a {dict replace command: type check is mandatory} { - catch {dict replace { a b c d e }} -> opt - dict get $opt -errorcode -} {TCL VALUE DICTIONARY} +} -errorCode {TCL VALUE DICTIONARY} -result {missing value to go with key} test dict-4.14 {dict replace command: type check is mandatory} -body { dict replace { a b {}c d } } -returnCodes error -result {dict element in braces followed by "c" instead of space} @@ -203,11 +199,7 @@ test dict-4.16a {dict replace command: type check is mandatory} { } {TCL VALUE DICTIONARY QUOTE} test dict-4.17 {dict replace command: type check is mandatory} -body { dict replace " a b \{c d " -} -returnCodes error -result {unmatched open brace in dict} -test dict-4.17a {dict replace command: type check is mandatory} { - catch {dict replace " a b \{c d "} -> opt - dict get $opt -errorcode -} {TCL VALUE DICTIONARY BRACE} +} -errorCode {TCL VALUE DICTIONARY BRACE} -result {unmatched open brace in dict} test dict-4.18 {dict replace command: canonicality forcing doesn't leak} { set example { a b c d } list $example [dict replace $example] diff --git a/tests/ioCmd.test b/tests/ioCmd.test index 948671e..3c4caa7 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -154,10 +154,10 @@ test iocmd-4.11 {read command} { test iocmd-4.12 {read command} -setup { set f [open $path(test1)] } -body { - list [catch {read $f 12z} msg] $msg $::errorCode + read $f 12z } -cleanup { close $f -} -result {1 {expected non-negative integer but got "12z"} {TCL VALUE NUMBER}} +} -result {expected non-negative integer but got "12z"} -errorCode {TCL VALUE NUMBER} test iocmd-5.1 {seek command} -returnCodes error -body { seek diff --git a/tests/source.test b/tests/source.test index 0235bd1..ab6b447 100644 --- a/tests/source.test +++ b/tests/source.test @@ -103,10 +103,9 @@ test source-2.6 {source error conditions} -setup { set sourcefile [makeFile {} _non_existent_] removeFile _non_existent_ } -body { - list [catch {source $sourcefile} msg] $msg $::errorCode -} -match listGlob -result [list 1 \ - {couldn't read file "*_non_existent_": no such file or directory} \ - {POSIX ENOENT {no such file or directory}}] + source $sourcefile +} -match glob -result {couldn't read file "*_non_existent_": no such file or directory} \ + -errorCode {POSIX ENOENT {no such file or directory}} test source-2.7 {utf-8 with BOM} -setup { set sourcefile [makeFile {} source.file] } -body { diff --git a/tests/tcltest.test b/tests/tcltest.test index 1487865..ca720ee 100644 --- a/tests/tcltest.test +++ b/tests/tcltest.test @@ -1207,7 +1207,7 @@ test tcltest-21.2 {force a test command failure} { } {1} } -returnCodes 1 - -result {bad option "1": must be -body, -cleanup, -constraints, -errorOutput, -match, -output, -result, -returnCodes, or -setup} + -result {bad option "1": must be -body, -cleanup, -constraints, -errorCode, -errorOutput, -match, -output, -result, -returnCodes, or -setup} } test tcltest-21.3 {test command with setup} { @@ -1300,7 +1300,7 @@ test tcltest-21.7 {test command - bad flag} { } } -returnCodes 1 - -result {bad option "-foobar": must be -body, -cleanup, -constraints, -errorOutput, -match, -output, -result, -returnCodes, or -setup} + -result {bad option "-foobar": must be -body, -cleanup, -constraints, -errorCode, -errorOutput, -match, -output, -result, -returnCodes, or -setup} } # alternate test command format (these are the same as 21.1-21.6, with the @@ -1320,7 +1320,7 @@ test tcltest-21.8 {force a test command failure} \ } \ -returnCodes 1 \ -cleanup {set ::tcltest::currentFailure $fail} \ - -result {bad option "1": must be -body, -cleanup, -constraints, -errorOutput, -match, -output, -result, -returnCodes, or -setup} + -result {bad option "1": must be -body, -cleanup, -constraints, -errorCode, -errorOutput, -match, -output, -result, -returnCodes, or -setup} test tcltest-21.9 {test command with setup} \ -setup {set foo 1} \ -- cgit v0.12 From bf9af9a40854d7116b0d6a17fae0594ce3c38f09 Mon Sep 17 00:00:00 2001 From: pspjuth Date: Tue, 23 Oct 2018 21:06:30 +0000 Subject: Cleanup --- library/tcltest/tcltest.tcl | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index 8b14142..c90d726 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -2022,11 +2022,10 @@ proc tcltest::test {name description args} { if {!$setupFailure && ($returnCode ni $returnCodes)} { set codeFailure 1 } - set errCodeFailure 0 + set errorCodeFailure 0 if {!$setupFailure && !$codeFailure && $returnCode == 1 && \ ![string match $errorCode $errorCodeRes(body)]} { - set codeFailure 1 - set errCodeFailure 1 + set errorCodeFailure 1 } # If expected output/error strings exist, we have to compare @@ -2122,7 +2121,7 @@ proc tcltest::test {name description args} { variable numTests if {!($setupFailure || $cleanupFailure || $coreFailure || $outputFailure || $errorFailure || $codeFailure - || $scriptFailure)} { + || $errorCodeFailure || $scriptFailure)} { if {$testLevel == 1} { incr numTests(Passed) if {[IsVerbose pass]} { @@ -2187,11 +2186,11 @@ proc tcltest::test {name description args} { ($match matching):\n$result" } } - if {$errCodeFailure} { - # TODO + if {$errorCodeFailure} { puts [outputChannel] "---- Error code was: '$errorCodeRes(body)'" puts [outputChannel] "---- Error code should have been: '$errorCode'" - } elseif {$codeFailure} { + } + if {$codeFailure} { switch -- $returnCode { 0 { set msg "Test completed normally" } 1 { set msg "Test generated error" } -- cgit v0.12 From 691b2ab5c41065dcaf399427499e6ecd6e9b4586 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 23 Oct 2018 23:34:34 +0000 Subject: update changes --- changes | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/changes b/changes index 62fdd4e..cef7989 100644 --- a/changes +++ b/changes @@ -8858,8 +8858,6 @@ improvements to regexp engine from Postgres (lane,porter,fellows,seltenreich) 2018-04-30 (bug)[27b682] race made [file delete] raise "no such file" (sebres) -2018-05-04 tzdata updated to Olson's tzdata2017e (jima) - 2018-06-04 (bug)[925643] 32/64 cleanup of filesystem DIR operations (sebres) 2018-06-18 (bug) leaks in TclSetEnv and env cache (coulter) @@ -8883,4 +8881,6 @@ improvements to regexp engine from Postgres (lane,porter,fellows,seltenreich) 2018-10-04 (bug) Prevent crash from NULL keyName (nijtmans) => registry 1.3.3 -- Released 8.6.9, October 17, 2018 - http://core.tcl-lang.org/tcl/ for details - +2018-10-18 tzdata updated to Olson's tzdata2017f (jima) + +- Released 8.6.9, October 31, 2018 - http://core.tcl-lang.org/tcl/ for details - -- cgit v0.12 From f44fb9b4500e047fdb9e361a17f44fa46dffec2b Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 24 Oct 2018 14:33:54 +0000 Subject: Request the tcltest version that provides the testing facilities used. --- tests/assemble.test | 2 +- tests/dict.test | 2 +- tests/ioCmd.test | 2 +- tests/source.test | 4 ++-- 4 files changed, 5 insertions(+), 5 deletions(-) diff --git a/tests/assemble.test b/tests/assemble.test index bea780a..05c1f9b 100644 --- a/tests/assemble.test +++ b/tests/assemble.test @@ -12,7 +12,7 @@ # Commands covered: assemble if {"::tcltest" ni [namespace children]} { - package require tcltest 2.2 + package require tcltest 2.5 namespace import -force ::tcltest::* } namespace eval tcl::unsupported {namespace export assemble} diff --git a/tests/dict.test b/tests/dict.test index 1479727..904ec53 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -10,7 +10,7 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/ioCmd.test b/tests/ioCmd.test index 3c4caa7..68bc542 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -14,7 +14,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/source.test b/tests/source.test index ab6b447..8b146d3 100644 --- a/tests/source.test +++ b/tests/source.test @@ -12,8 +12,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[catch {package require tcltest 2.1}]} { - puts stderr "Skipping tests in [info script]. tcltest 2.1 required." +if {[catch {package require tcltest 2.5}]} { + puts stderr "Skipping tests in [info script]. tcltest 2.5 required." return } -- cgit v0.12 From c69ccc749e9de9c32a0e0c7b6f733b8e64e1209f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 24 Oct 2018 21:22:18 +0000 Subject: Backport "registry" version 1.3.3, so all active branches now have the same registry version. (this commit must -eventually- be merge-marked to core-8-6-branch, since everything is there already) --- library/reg/pkgIndex.tcl | 8 +- tests/registry.test | 294 +++++++++++++-------- win/Makefile.in | 6 +- win/configure.in | 4 +- win/makefile.bc | 4 +- win/makefile.vc | 10 +- win/rules.vc | 4 +- win/tclWinReg.c | 666 +++++++++++++++++++++++------------------------ 8 files changed, 519 insertions(+), 477 deletions(-) diff --git a/library/reg/pkgIndex.tcl b/library/reg/pkgIndex.tcl index 1241f2a..12c7ea5 100755 --- a/library/reg/pkgIndex.tcl +++ b/library/reg/pkgIndex.tcl @@ -1,9 +1,9 @@ if {![package vsatisfies [package provide Tcl] 8]} return if {[info sharedlibextension] != ".dll"} return if {[info exists ::tcl_platform(debug)]} { - package ifneeded registry 1.2.2 \ - [list load [file join $dir tclreg12g.dll] registry] + package ifneeded registry 1.3.3 \ + [list load [file join $dir tclreg13g.dll] registry] } else { - package ifneeded registry 1.2.2 \ - [list load [file join $dir tclreg12.dll] registry] + package ifneeded registry 1.3.3 \ + [list load [file join $dir tclreg13.dll] registry] } diff --git a/tests/registry.test b/tests/registry.test index cbca4fd..539ba2d 100644 --- a/tests/registry.test +++ b/tests/registry.test @@ -19,7 +19,7 @@ testConstraint reg 0 if {[testConstraint win]} { if {![catch { ::tcltest::loadTestedCommands - package require registry + set ::regver [package require registry 1.3.3] }]} { testConstraint reg 1 } @@ -30,17 +30,35 @@ testConstraint english [expr { [llength [info commands testlocale]] && [string match "English*" [testlocale all ""]] }] - + +test registry-1.0 {check if we are testing the right dll} {win reg} { + set ::regver +} {1.3.3} test registry-1.1 {argument parsing for registry command} {win reg} { list [catch {registry} msg] $msg -} {1 {wrong # args: should be "registry option ?arg arg ...?"}} +} {1 {wrong # args: should be "registry ?-32bit|-64bit? option ?arg ...?"}} +test registry-1.1a {argument parsing for registry command} {win reg} { + list [catch {registry -32bit} msg] $msg +} {1 {wrong # args: should be "registry ?-32bit|-64bit? option ?arg ...?"}} +test registry-1.1b {argument parsing for registry command} {win reg} { + list [catch {registry -64bit} msg] $msg +} {1 {wrong # args: should be "registry ?-32bit|-64bit? option ?arg ...?"}} test registry-1.2 {argument parsing for registry command} {win reg} { list [catch {registry foo} msg] $msg } {1 {bad option "foo": must be broadcast, delete, get, keys, set, type, or values}} +test registry-1.2a {argument parsing for registry command} {win reg} { + list [catch {registry -33bit foo} msg] $msg +} {1 {bad mode "-33bit": must be -32bit or -64bit}} test registry-1.3 {argument parsing for registry command} {win reg} { list [catch {registry d} msg] $msg } {1 {wrong # args: should be "registry delete keyName ?valueName?"}} +test registry-1.3a {argument parsing for registry command} {win reg} { + list [catch {registry -32bit d} msg] $msg +} {1 {wrong # args: should be "registry -32bit delete keyName ?valueName?"}} +test registry-1.3b {argument parsing for registry command} {win reg} { + list [catch {registry -64bit d} msg] $msg +} {1 {wrong # args: should be "registry -64bit delete keyName ?valueName?"}} test registry-1.4 {argument parsing for registry command} {win reg} { list [catch {registry delete} msg] $msg } {1 {wrong # args: should be "registry delete keyName ?valueName?"}} @@ -51,6 +69,12 @@ test registry-1.5 {argument parsing for registry command} {win reg} { test registry-1.6 {argument parsing for registry command} {win reg} { list [catch {registry g} msg] $msg } {1 {wrong # args: should be "registry get keyName valueName"}} +test registry-1.6a {argument parsing for registry command} {win reg} { + list [catch {registry -32bit g} msg] $msg +} {1 {wrong # args: should be "registry -32bit get keyName valueName"}} +test registry-1.6b {argument parsing for registry command} {win reg} { + list [catch {registry -64bit g} msg] $msg +} {1 {wrong # args: should be "registry -64bit get keyName valueName"}} test registry-1.7 {argument parsing for registry command} {win reg} { list [catch {registry get} msg] $msg } {1 {wrong # args: should be "registry get keyName valueName"}} @@ -64,6 +88,12 @@ test registry-1.9 {argument parsing for registry command} {win reg} { test registry-1.10 {argument parsing for registry command} {win reg} { list [catch {registry k} msg] $msg } {1 {wrong # args: should be "registry keys keyName ?pattern?"}} +test registry-1.10a {argument parsing for registry command} {win reg} { + list [catch {registry -32bit k} msg] $msg +} {1 {wrong # args: should be "registry -32bit keys keyName ?pattern?"}} +test registry-1.10b {argument parsing for registry command} {win reg} { + list [catch {registry -64bit k} msg] $msg +} {1 {wrong # args: should be "registry -64bit keys keyName ?pattern?"}} test registry-1.11 {argument parsing for registry command} {win reg} { list [catch {registry keys} msg] $msg } {1 {wrong # args: should be "registry keys keyName ?pattern?"}} @@ -74,6 +104,12 @@ test registry-1.12 {argument parsing for registry command} {win reg} { test registry-1.13 {argument parsing for registry command} {win reg} { list [catch {registry s} msg] $msg } {1 {wrong # args: should be "registry set keyName ?valueName data ?type??"}} +test registry-1.13a {argument parsing for registry command} {win reg} { + list [catch {registry -32bit s} msg] $msg +} {1 {wrong # args: should be "registry -32bit set keyName ?valueName data ?type??"}} +test registry-1.13b {argument parsing for registry command} {win reg} { + list [catch {registry -64bit s} msg] $msg +} {1 {wrong # args: should be "registry -64bit set keyName ?valueName data ?type??"}} test registry-1.14 {argument parsing for registry command} {win reg} { list [catch {registry set} msg] $msg } {1 {wrong # args: should be "registry set keyName ?valueName data ?type??"}} @@ -87,6 +123,12 @@ test registry-1.16 {argument parsing for registry command} {win reg} { test registry-1.17 {argument parsing for registry command} {win reg} { list [catch {registry t} msg] $msg } {1 {wrong # args: should be "registry type keyName valueName"}} +test registry-1.17a {argument parsing for registry command} {win reg} { + list [catch {registry -32bit t} msg] $msg +} {1 {wrong # args: should be "registry -32bit type keyName valueName"}} +test registry-1.17b {argument parsing for registry command} {win reg} { + list [catch {registry -64bit t} msg] $msg +} {1 {wrong # args: should be "registry -64bit type keyName valueName"}} test registry-1.18 {argument parsing for registry command} {win reg} { list [catch {registry type} msg] $msg } {1 {wrong # args: should be "registry type keyName valueName"}} @@ -100,6 +142,12 @@ test registry-1.20 {argument parsing for registry command} {win reg} { test registry-1.21 {argument parsing for registry command} {win reg} { list [catch {registry v} msg] $msg } {1 {wrong # args: should be "registry values keyName ?pattern?"}} +test registry-1.21a {argument parsing for registry command} {win reg} { + list [catch {registry -32bit v} msg] $msg +} {1 {wrong # args: should be "registry -32bit values keyName ?pattern?"}} +test registry-1.21b {argument parsing for registry command} {win reg} { + list [catch {registry -64bit v} msg] $msg +} {1 {wrong # args: should be "registry -64bit values keyName ?pattern?"}} test registry-1.22 {argument parsing for registry command} {win reg} { list [catch {registry values} msg] $msg } {1 {wrong # args: should be "registry values keyName ?pattern?"}} @@ -111,10 +159,10 @@ test registry-2.1 {DeleteKey: bad key} {win reg} { list [catch {registry delete foo} msg] $msg } {1 {bad root name "foo": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, or HKEY_DYN_DATA}} test registry-2.2 {DeleteKey: bad key} {win reg} { - list [catch {registry delete HKEY_CURRENT_USER} msg] $msg + list [catch {registry delete HKEY_CLASSES_ROOT} msg] $msg } {1 {bad key: cannot delete root keys}} test registry-2.3 {DeleteKey: bad key} {win reg} { - list [catch {registry delete HKEY_CURRENT_USER\\} msg] $msg + list [catch {registry delete HKEY_CLASSES_ROOT\\} msg] $msg } {1 {bad key: cannot delete root keys}} test registry-2.4 {DeleteKey: subkey at root level} {win reg} { registry set HKEY_CURRENT_USER\\TclFoobar @@ -235,7 +283,7 @@ test registry-4.7 {GetKeyNames: Unicode} {win reg english} { registry delete HKEY_CURRENT_USER\\TclFoobar set result } "baz\u00c7bar blat" -test registry-4.8 {GetKeyNames: Unicode} {win reg nt} { +test registry-4.8 {GetKeyNames: Unicode} {win reg} { registry delete HKEY_CURRENT_USER\\TclFoobar registry set HKEY_CURRENT_USER\\TclFoobar\\baz\u30b7bar registry set HKEY_CURRENT_USER\\TclFoobar\\blat @@ -439,7 +487,7 @@ test registry-6.17 {GetValue: Unicode value names} {win reg} { registry delete HKEY_CURRENT_USER\\TclFoobar set result } foobar -test registry-6.18 {GetValue: values with Unicode strings} {win reg nt} { +test registry-6.18 {GetValue: values with Unicode strings} {win reg} { registry set HKEY_CURRENT_USER\\TclFoobar val1 {foo ba\u30b7r baz} multi_sz set result [registry get HKEY_CURRENT_USER\\TclFoobar val1] registry delete HKEY_CURRENT_USER\\TclFoobar @@ -457,161 +505,181 @@ test registry-6.20 {GetValue: values with Unicode strings with embedded nulls} { registry delete HKEY_CURRENT_USER\\TclFoobar set result } "foo ba r baz" -test registry-6.21 {GetValue: very long value names and values} {pcOnly reg} { - registry set HKEY_CURRENT_USER\\TclFoobar [string repeat k 199] [string repeat x 199] multi_sz - set result [registry get HKEY_CURRENT_USER\\TclFoobar [string repeat k 199]] +test registry-6.21 {GetValue: very long value names and values} {win reg} { + registry set HKEY_CURRENT_USER\\TclFoobar [string repeat k 16383] [string repeat x 16383] multi_sz + set result [registry get HKEY_CURRENT_USER\\TclFoobar [string repeat k 16383]] registry delete HKEY_CURRENT_USER\\TclFoobar set result -} [string repeat x 199] +} [string repeat x 16383] -test registry-7.1 {GetValueNames: bad key} {win reg english} { +test registry-7.1 {GetValueNames: bad key} -constraints {win reg english} -setup { registry delete HKEY_CURRENT_USER\\TclFoobar - list [catch {registry values HKEY_CURRENT_USER\\TclFoobar} msg] $msg -} {1 {unable to open key: The system cannot find the file specified.}} -test registry-7.2 {GetValueNames} {win reg} { +} -body { + registry values HKEY_CURRENT_USER\\TclFoobar +} -returnCodes error -result {unable to open key: The system cannot find the file specified.} +test registry-7.2 {GetValueNames} -constraints {win reg} -setup { registry delete HKEY_CURRENT_USER\\TclFoobar registry set HKEY_CURRENT_USER\\TclFoobar baz foobar - set result [registry values HKEY_CURRENT_USER\\TclFoobar] +} -body { + registry values HKEY_CURRENT_USER\\TclFoobar +} -cleanup { registry delete HKEY_CURRENT_USER\\TclFoobar - set result -} baz -test registry-7.3 {GetValueNames} {win reg} { +} -result baz +test registry-7.3 {GetValueNames} -constraints {win reg} -setup { registry delete HKEY_CURRENT_USER\\TclFoobar registry set HKEY_CURRENT_USER\\TclFoobar baz foobar1 registry set HKEY_CURRENT_USER\\TclFoobar blat foobar2 registry set HKEY_CURRENT_USER\\TclFoobar {} foobar3 - set result [lsort [registry values HKEY_CURRENT_USER\\TclFoobar]] +} -body { + lsort [registry values HKEY_CURRENT_USER\\TclFoobar] +} -cleanup { registry delete HKEY_CURRENT_USER\\TclFoobar - set result -} {{} baz blat} -test registry-7.4 {GetValueNames: remote key} {win reg nonPortable english} { +} -result {{} baz blat} +test registry-7.4 {GetValueNames: remote key} -constraints {win reg nonPortable english} -body { set hostname [info hostname] registry set \\\\$hostname\\HKEY_CURRENT_USER\\TclFoobar baz blat set result [registry values \\\\$hostname\\HKEY_CURRENT_USER\\TclFoobar] registry delete \\\\$hostname\\HKEY_CURRENT_USER\\TclFoobar set result -} baz -test registry-7.5 {GetValueNames: empty key} {win reg} { +} -result baz +test registry-7.5 {GetValueNames: empty key} -constraints {win reg} -setup { registry delete HKEY_CURRENT_USER\\TclFoobar registry set HKEY_CURRENT_USER\\TclFoobar - set result [registry values HKEY_CURRENT_USER\\TclFoobar] +} -body { + registry values HKEY_CURRENT_USER\\TclFoobar +} -cleanup { registry delete HKEY_CURRENT_USER\\TclFoobar - set result -} {} -test registry-7.6 {GetValueNames: patterns} {win reg} { +} -result {} +test registry-7.6 {GetValueNames: patterns} -constraints {win reg} -setup { registry delete HKEY_CURRENT_USER\\TclFoobar registry set HKEY_CURRENT_USER\\TclFoobar baz foobar1 registry set HKEY_CURRENT_USER\\TclFoobar blat foobar2 registry set HKEY_CURRENT_USER\\TclFoobar foo foobar3 - set result [lsort [registry values HKEY_CURRENT_USER\\TclFoobar b*]] +} -body { + lsort [registry values HKEY_CURRENT_USER\\TclFoobar b*] +} -cleanup { registry delete HKEY_CURRENT_USER\\TclFoobar - set result -} {baz blat} -test registry-7.7 {GetValueNames: names with spaces} {win reg} { +} -result {baz blat} +test registry-7.7 {GetValueNames: names with spaces} -constraints {win reg} -setup { registry delete HKEY_CURRENT_USER\\TclFoobar registry set HKEY_CURRENT_USER\\TclFoobar baz\ bar foobar1 registry set HKEY_CURRENT_USER\\TclFoobar blat foobar2 registry set HKEY_CURRENT_USER\\TclFoobar foo foobar3 - set result [lsort [registry values HKEY_CURRENT_USER\\TclFoobar b*]] +} -body { + lsort [registry values HKEY_CURRENT_USER\\TclFoobar b*] +} -cleanup { registry delete HKEY_CURRENT_USER\\TclFoobar - set result -} {{baz bar} blat} +} -result {{baz bar} blat} -test registry-8.1 {OpenSubKey} {win reg nonPortable english} { - # This test will only succeed if the current user does not have registry - # access on the specified machine. - list [catch {registry keys {\\mom\HKEY_LOCAL_MACHINE}} msg] $msg -} {1 {unable to open key: Access is denied.}} -test registry-8.2 {OpenSubKey} {win reg} { +test registry-8.1 {OpenSubKey} -constraints {win reg nonPortable english} \ + -body { + # This test will only succeed if the current user does not have + # registry access on the specified machine. + registry keys {\\mom\HKEY_LOCAL_MACHINE} + } -returnCodes error -result "unable to open key: Access is denied." +test registry-8.2 {OpenSubKey} -constraints {win reg} -setup { registry delete HKEY_CURRENT_USER\\TclFoobar registry set HKEY_CURRENT_USER\\TclFoobar - set result [registry keys HKEY_CURRENT_USER TclFoobar] +} -body { + registry keys HKEY_CURRENT_USER TclFoobar +} -cleanup { registry delete HKEY_CURRENT_USER\\TclFoobar - set result -} TclFoobar -test registry-8.3 {OpenSubKey} {win reg english} { +} -result {TclFoobar} +test registry-8.3 {OpenSubKey} -constraints {win reg english} -setup { registry delete HKEY_CURRENT_USER\\TclFoobar - list [catch {registry keys HKEY_CURRENT_USER\\TclFoobar} msg] $msg -} {1 {unable to open key: The system cannot find the file specified.}} +} -body { + registry keys HKEY_CURRENT_USER\\TclFoobar +} -returnCodes error \ + -result "unable to open key: The system cannot find the file specified." -test registry-9.1 {ParseKeyName: bad keys} {win reg} { - list [catch {registry values \\} msg] $msg -} "1 {bad key \"\\\": must start with a valid root}" -test registry-9.2 {ParseKeyName: bad keys} {win reg} { - list [catch {registry values \\foobar} msg] $msg -} {1 {bad key "\foobar": must start with a valid root}} -test registry-9.3 {ParseKeyName: bad keys} {win reg} { - list [catch {registry values \\\\} msg] $msg -} {1 {bad root name "": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, or HKEY_DYN_DATA}} -test registry-9.4 {ParseKeyName: bad keys} {win reg} { - list [catch {registry values \\\\\\} msg] $msg -} {1 {bad root name "": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, or HKEY_DYN_DATA}} -test registry-9.5 {ParseKeyName: bad keys} {win reg english nt} { - list [catch {registry values \\\\\\HKEY_CURRENT_USER} msg] $msg -} {1 {unable to open key: The network address is invalid.}} -test registry-9.6 {ParseKeyName: bad keys} {win reg} { - list [catch {registry values \\\\gaspode} msg] $msg -} {1 {bad root name "": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, or HKEY_DYN_DATA}} -test registry-9.7 {ParseKeyName: bad keys} {win reg} { - list [catch {registry values foobar} msg] $msg -} {1 {bad root name "foobar": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, or HKEY_DYN_DATA}} -test registry-9.8 {ParseKeyName: null keys} {win reg} { - list [catch {registry delete HKEY_CURRENT_USER\\} msg] $msg -} {1 {bad key: cannot delete root keys}} -test registry-9.9 {ParseKeyName: null keys} {win reg english} { - list [catch {registry keys HKEY_CURRENT_USER\\TclFoobar\\baz} msg] $msg -} {1 {unable to open key: The system cannot find the file specified.}} +test registry-9.1 {ParseKeyName: bad keys} -constraints {win reg} -body { + registry values \\ +} -returnCodes error -result "bad key \"\\\": must start with a valid root" +test registry-9.2 {ParseKeyName: bad keys} -constraints {win reg} -body { + registry values \\foobar +} -returnCodes error -result {bad key "\foobar": must start with a valid root} +test registry-9.3 {ParseKeyName: bad keys} -constraints {win reg} -body { + registry values \\\\ +} -returnCodes error -result {bad root name "": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, or HKEY_DYN_DATA} +test registry-9.4 {ParseKeyName: bad keys} -constraints {win reg} -body { + registry values \\\\\\ +} -returnCodes error -result {bad root name "": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, or HKEY_DYN_DATA} +test registry-9.5 {ParseKeyName: bad keys} -constraints {win reg english} -body { + registry values \\\\\\HKEY_CLASSES_ROOT +} -returnCodes error -result {unable to open key: The network address is invalid.} +test registry-9.6 {ParseKeyName: bad keys} -constraints {win reg} -body { + registry values \\\\gaspode +} -returnCodes error -result {bad root name "": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, or HKEY_DYN_DATA} +test registry-9.7 {ParseKeyName: bad keys} -constraints {win reg} -body { + registry values foobar +} -returnCodes error -result {bad root name "foobar": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, or HKEY_DYN_DATA} +test registry-9.8 {ParseKeyName: null keys} -constraints {win reg} -body { + registry delete HKEY_CLASSES_ROOT\\ +} -returnCodes error -result {bad key: cannot delete root keys} +test registry-9.9 {ParseKeyName: null keys} \ + -constraints {win reg english} \ + -body {registry keys HKEY_CLASSES_ROOT\\TclFoobar\\baz} \ + -returnCodes error \ + -result {unable to open key: The system cannot find the file specified.} -test registry-10.1 {RecursiveDeleteKey} {win reg} { +test registry-10.1 {RecursiveDeleteKey} -constraints {win reg} -setup { registry delete HKEY_CURRENT_USER\\TclFoobar +} -body { registry set HKEY_CURRENT_USER\\TclFoobar\\test1 registry set HKEY_CURRENT_USER\\TclFoobar\\test2\\test3 registry delete HKEY_CURRENT_USER\\TclFoobar set result [registry keys HKEY_CURRENT_USER TclFoobar] set result -} {} -test registry-10.2 {RecursiveDeleteKey} {win reg} { +} -result {} +test registry-10.2 {RecursiveDeleteKey} -constraints {win reg} -setup { registry delete HKEY_CURRENT_USER\\TclFoobar registry set HKEY_CURRENT_USER\\TclFoobar\\test1 registry set HKEY_CURRENT_USER\\TclFoobar\\test2\\test3 - set result [registry delete HKEY_CURRENT_USER\\TclFoobar\\test2\\test4] +} -body { + registry delete HKEY_CURRENT_USER\\TclFoobar\\test2\\test4 +} -cleanup { registry delete HKEY_CURRENT_USER\\TclFoobar - set result -} {} - -test registry-11.1 {SetValue: recursive creation} {win reg} { - registry delete HKEY_CURRENT_USER\\TclFoobar - registry set HKEY_CURRENT_USER\\TclFoobar\\baz blat foobar - set result [registry get HKEY_CURRENT_USER\\TclFoobar\\baz blat] -} foobar -test registry-11.2 {SetValue: modification} {win reg} { - registry delete HKEY_CURRENT_USER\\TclFoobar - registry set HKEY_CURRENT_USER\\TclFoobar\\baz blat foobar - registry set HKEY_CURRENT_USER\\TclFoobar\\baz blat frob - set result [registry get HKEY_CURRENT_USER\\TclFoobar\\baz blat] -} frob -test registry-11.3 {SetValue: failure} {win reg nonPortable english} { - # This test will only succeed if the current user does not have registry - # access on the specified machine. - list [catch {registry set {\\mom\HKEY_CURRENT_USER\TclFoobar} bar foobar} msg] $msg -} {1 {unable to open key: Access is denied.}} +} -result {} -test registry-12.1 {BroadcastValue} {win reg} { - list [catch {registry broadcast} msg] $msg -} {1 {wrong # args: should be "registry broadcast keyName ?-timeout millisecs?"}} -test registry-12.2 {BroadcastValue} {win reg} { - list [catch {registry broadcast "" -time} msg] $msg -} {1 {wrong # args: should be "registry broadcast keyName ?-timeout millisecs?"}} -test registry-12.3 {BroadcastValue} {win reg} { - list [catch {registry broadcast "" - 500} msg] $msg -} {1 {wrong # args: should be "registry broadcast keyName ?-timeout millisecs?"}} -test registry-12.4 {BroadcastValue} {win reg} { - list [catch {registry broadcast {Environment}} msg] $msg -} {0 {1 0}} -test registry-12.5 {BroadcastValue} {win reg} { - list [catch {registry b {}} msg] $msg -} {0 {1 0}} +test registry-11.1 {SetValue: recursive creation} \ + -constraints {win reg} -setup { + registry delete HKEY_CURRENT_USER\\TclFoobar + } -body { + registry set HKEY_CURRENT_USER\\TclFoobar\\baz blat foobar + set result [registry get HKEY_CURRENT_USER\\TclFoobar\\baz blat] + } -result {foobar} +test registry-11.2 {SetValue: modification} -constraints {win reg} \ + -setup { + registry delete HKEY_CURRENT_USER\\TclFoobar + } -body { + registry set HKEY_CURRENT_USER\\TclFoobar\\baz blat foobar + registry set HKEY_CURRENT_USER\\TclFoobar\\baz blat frob + set result [registry get HKEY_CURRENT_USER\\TclFoobar\\baz blat] + } -result {frob} +test registry-11.3 {SetValue: failure} \ + -constraints {win reg nonPortable english} \ + -body { + # This test will only succeed if the current user does not have + # registry access on the specified machine. + registry set {\\mom\HKEY_CURRENT_USER\TclFoobar} bar foobar + } -returnCodes error -result {unable to open key: Access is denied.} +test registry-12.1 {BroadcastValue} -constraints {win reg} -body { + registry broadcast +} -returnCodes error -result "wrong # args: should be \"registry broadcast keyName ?-timeout milliseconds?\"" +test registry-12.2 {BroadcastValue} -constraints {win reg} -body { + registry broadcast "" -time +} -returnCodes error -result "wrong # args: should be \"registry broadcast keyName ?-timeout milliseconds?\"" +test registry-12.3 {BroadcastValue} -constraints {win reg} -body { + registry broadcast "" - 500 +} -returnCodes error -result "wrong # args: should be \"registry broadcast keyName ?-timeout milliseconds?\"" +test registry-12.4 {BroadcastValue} -constraints {win reg} -body { + registry broadcast {Environment} +} -result {1 0} +test registry-12.5 {BroadcastValue} -constraints {win reg} -body { + registry b {} +} -result {1 0} + # cleanup ::tcltest::cleanupTests return diff --git a/win/Makefile.in b/win/Makefile.in index d9b52fa..6d1ce95 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -495,7 +495,7 @@ tclAppInit.${OBJEXT} : tclAppInit.c # The following objects should be built using the stub interfaces tclWinReg.${OBJEXT} : tclWinReg.c - $(CC) -c $(CC_SWITCHES) -DUSE_TCL_STUBS @DEPARG@ $(CC_OBJNAME) + $(CC) -c $(CC_SWITCHES) -DUNICODE -D_UNICODE -DUSE_TCL_STUBS @DEPARG@ $(CC_OBJNAME) tclWinDde.${OBJEXT} : tclWinDde.c $(CC) -c $(CC_SWITCHES) -DUSE_TCL_STUBS @DEPARG@ $(CC_OBJNAME) @@ -710,13 +710,13 @@ test: binaries $(TCLTEST) TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \ ./$(TCLTEST) "$(ROOT_DIR_NATIVE)/tests/all.tcl" $(TESTFLAGS) \ -load "package ifneeded dde 1.3.3 [list load [file normalize ${DDE_DLL_FILE}] dde]; \ - package ifneeded registry 1.2.2 [list load [file normalize ${REG_DLL_FILE}] registry]" | ./$(CAT32) + package ifneeded registry 1.3.3 [list load [file normalize ${REG_DLL_FILE}] registry]" | ./$(CAT32) # Useful target to launch a built tcltest with the proper path,... runtest: binaries $(TCLTEST) @TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \ ./$(TCLTEST) $(TESTFLAGS) -load "package ifneeded dde 1.3.3 [list load [file normalize ${DDE_DLL_FILE}] dde]; \ - package ifneeded registry 1.2.2 [list load [file normalize ${REG_DLL_FILE}] registry]" $(SCRIPT) + package ifneeded registry 1.3.3 [list load [file normalize ${REG_DLL_FILE}] registry]" $(SCRIPT) # This target can be used to run tclsh from the build directory via # `make shell SCRIPT=foo.tcl` diff --git a/win/configure.in b/win/configure.in index 8931a38..fa75e5b 100644 --- a/win/configure.in +++ b/win/configure.in @@ -22,9 +22,9 @@ TCL_DDE_MAJOR_VERSION=1 TCL_DDE_MINOR_VERSION=3 DDEVER=$TCL_DDE_MAJOR_VERSION$TCL_DDE_MINOR_VERSION -TCL_REG_VERSION=1.2 +TCL_REG_VERSION=1.3 TCL_REG_MAJOR_VERSION=1 -TCL_REG_MINOR_VERSION=2 +TCL_REG_MINOR_VERSION=3 REGVER=$TCL_REG_MAJOR_VERSION$TCL_REG_MINOR_VERSION #------------------------------------------------------------------------ diff --git a/win/makefile.bc b/win/makefile.bc index 6421682..20d89bc 100644 --- a/win/makefile.bc +++ b/win/makefile.bc @@ -130,8 +130,8 @@ VERSION = 85 DDEVERSION = 13 DDEDOTVERSION = 1.3 -REGVERSION = 12 -REGDOTVERSION = 1.2 +REGVERSION = 13 +REGDOTVERSION = 1.3 BINROOT = .. !IF "$(NODEBUG)" == "1" diff --git a/win/makefile.vc b/win/makefile.vc index aedb7a6..c330fcd 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -185,7 +185,7 @@ VERSION = $(TCL_MAJOR_VERSION)$(TCL_MINOR_VERSION) DDEDOTVERSION = 1.3 DDEVERSION = $(DDEDOTVERSION:.=) -REGDOTVERSION = 1.2 +REGDOTVERSION = 1.3 REGVERSION = $(REGDOTVERSION:.=) BINROOT = . @@ -539,13 +539,13 @@ test-core: setup $(TCLTEST) dlls $(CAT32) !if "$(OS)" == "Windows_NT" || "$(MSVCDIR)" == "IDE" $(DEBUGGER) $(TCLTEST) "$(ROOT:\=/)/tests/all.tcl" $(TESTFLAGS) -loadfile << package ifneeded dde 1.3.3 [list load "$(TCLDDELIB:\=/)" dde] - package ifneeded registry 1.2.2 [list load "$(TCLREGLIB:\=/)" registry] + package ifneeded registry 1.3.3 [list load "$(TCLREGLIB:\=/)" registry] << !else @echo Please wait while the tests are collected... $(TCLTEST) "$(ROOT:\=/)/tests/all.tcl" $(TESTFLAGS) -loadfile << > tests.log package ifneeded dde 1.3.3 "$(TCLDDELIB:\=/)" dde] - package ifneeded registry 1.2.2 "$(TCLREGLIB:\=/)" registry] + package ifneeded registry 1.3.3 "$(TCLREGLIB:\=/)" registry] << type tests.log | more !endif @@ -885,9 +885,9 @@ $(TMP_DIR)\tclAppInit.obj: $(WINDIR)\tclAppInit.c $(TMP_DIR)\tclWinReg.obj: $(WINDIR)\tclWinReg.c !if $(STATIC_BUILD) - $(cc32) $(TCL_CFLAGS) -DTCL_THREADS=1 -DSTATIC_BUILD -Fo$@ $? + $(cc32) $(TCL_CFLAGS) -DTCL_THREADS=1 -DSTATIC_BUILD -DUNICODE -D_UNICODE -Fo$@ $? !else - $(cc32) $(TCL_CFLAGS) -DTCL_THREADS=1 -DUSE_TCL_STUBS -Fo$@ $? + $(cc32) $(TCL_CFLAGS) -DTCL_THREADS=1 -DUSE_TCL_STUBS -DUNICODE -D_UNICODE -Fo$@ $? !endif diff --git a/win/rules.vc b/win/rules.vc index 2edaa49..0ae0e8e 100644 --- a/win/rules.vc +++ b/win/rules.vc @@ -590,7 +590,7 @@ TCLSH = "$(_TCLDIR)\bin\tclsh$(TCL_VERSION)t$(SUFX).exe" TCLSTUBLIB = "$(_TCLDIR)\lib\tclstub$(TCL_VERSION).lib" TCLIMPLIB = "$(_TCLDIR)\lib\tcl$(TCL_VERSION)$(SUFX).lib" TCL_LIBRARY = $(_TCLDIR)\lib -TCLREGLIB = "$(_TCLDIR)\lib\tclreg12$(SUFX:t=).lib" +TCLREGLIB = "$(_TCLDIR)\lib\tclreg13$(SUFX:t=).lib" TCLDDELIB = "$(_TCLDIR)\lib\tcldde13$(SUFX:t=).lib" COFFBASE = \must\have\tcl\sources\to\build\this\target TCLTOOLSDIR = \must\have\tcl\sources\to\build\this\target @@ -603,7 +603,7 @@ TCLSH = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tclsh$(TCL_VERSION)t$(SUFX).exe" TCLSTUBLIB = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tclstub$(TCL_VERSION).lib" TCLIMPLIB = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tcl$(TCL_VERSION)$(SUFX).lib" TCL_LIBRARY = $(_TCLDIR)\library -TCLREGLIB = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tclreg12$(SUFX:t=).lib" +TCLREGLIB = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tclreg13$(SUFX:t=).lib" TCLDDELIB = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tcldde13$(SUFX:t=).lib" COFFBASE = "$(_TCLDIR)\win\coffbase.txt" TCLTOOLSDIR = $(_TCLDIR)\tools diff --git a/win/tclWinReg.c b/win/tclWinReg.c index a6ce2ce..f3d7a07 100644 --- a/win/tclWinReg.c +++ b/win/tclWinReg.c @@ -12,36 +12,41 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ +#undef STATIC_BUILD +#ifndef USE_TCL_STUBS +# define USE_TCL_STUBS +#endif #include "tclInt.h" -#include "tclPort.h" #ifdef _MSC_VER # pragma comment (lib, "advapi32.lib") #endif #include /* - * TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the - * Registry_Init declaration is in the source file itself, which is only - * accessed when we are building a library. + * Ensure that we can say which registry is being accessed. */ -#undef TCL_STORAGE_CLASS -#define TCL_STORAGE_CLASS DLLEXPORT +#ifndef KEY_WOW64_64KEY +# define KEY_WOW64_64KEY (0x0100) +#endif +#ifndef KEY_WOW64_32KEY +# define KEY_WOW64_32KEY (0x0200) +#endif /* * The maximum length of a sub-key name. */ #ifndef MAX_KEY_LENGTH -#define MAX_KEY_LENGTH 256 +# define MAX_KEY_LENGTH 256 #endif /* * The following macros convert between different endian ints. */ -#define SWAPWORD(x) MAKEWORD(HIBYTE(x), LOBYTE(x)) -#define SWAPLONG(x) MAKELONG(SWAPWORD(HIWORD(x)), SWAPWORD(LOWORD(x))) +#define SWAPWORD(x) MAKEWORD(HIBYTE(x), LOBYTE(x)) +#define SWAPLONG(x) MAKELONG(SWAPWORD(HIWORD(x)), SWAPWORD(LOWORD(x))) /* * The following flag is used in OpenKeys to indicate that the specified key @@ -55,7 +60,7 @@ * system predefined keys. */ -static CONST char *rootKeyNames[] = { +static const char *const rootKeyNames[] = { "HKEY_LOCAL_MACHINE", "HKEY_USERS", "HKEY_CLASSES_ROOT", "HKEY_CURRENT_USER", "HKEY_CURRENT_CONFIG", "HKEY_PERFORMANCE_DATA", "HKEY_DYN_DATA", NULL @@ -66,7 +71,7 @@ static const HKEY rootKeys[] = { HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, HKEY_DYN_DATA }; -static CONST char REGISTRY_ASSOC_KEY[] = "registry::command"; +static const char REGISTRY_ASSOC_KEY[] = "registry::command"; /* * The following table maps from registry types to strings. Note that the @@ -74,7 +79,7 @@ static CONST char REGISTRY_ASSOC_KEY[] = "registry::command"; * types so we don't need a separate table to hold the mapping. */ -static CONST char *typeNames[] = { +static const char *const typeNames[] = { "none", "sz", "expand_sz", "binary", "dword", "dword_big_endian", "link", "multi_sz", "resource_list", NULL }; @@ -82,100 +87,26 @@ static CONST char *typeNames[] = { static DWORD lastType = REG_RESOURCE_LIST; /* - * The following structures allow us to select between the Unicode and ASCII - * interfaces at run time based on whether Unicode APIs are available. The - * Unicode APIs are preferable because they will handle characters outside of - * the current code page. - */ - -typedef struct RegWinProcs { - int useWide; - - LONG (WINAPI *regConnectRegistryProc)(CONST TCHAR *, HKEY, PHKEY); - LONG (WINAPI *regCreateKeyExProc)(HKEY, CONST TCHAR *, DWORD, TCHAR *, - DWORD, REGSAM, SECURITY_ATTRIBUTES *, HKEY *, DWORD *); - LONG (WINAPI *regDeleteKeyProc)(HKEY, CONST TCHAR *); - LONG (WINAPI *regDeleteValueProc)(HKEY, CONST TCHAR *); - LONG (WINAPI *regEnumKeyProc)(HKEY, DWORD, TCHAR *, DWORD); - LONG (WINAPI *regEnumKeyExProc)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *, - TCHAR *, DWORD *, FILETIME *); - LONG (WINAPI *regEnumValueProc)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *, - DWORD *, BYTE *, DWORD *); - LONG (WINAPI *regOpenKeyExProc)(HKEY, CONST TCHAR *, DWORD, REGSAM, - HKEY *); - LONG (WINAPI *regQueryValueExProc)(HKEY, CONST TCHAR *, DWORD *, DWORD *, - BYTE *, DWORD *); - LONG (WINAPI *regSetValueExProc)(HKEY, CONST TCHAR *, DWORD, DWORD, - CONST BYTE*, DWORD); -} RegWinProcs; - -static RegWinProcs *regWinProcs; - -static RegWinProcs asciiProcs = { - 0, - - (LONG (WINAPI *)(CONST TCHAR *, HKEY, PHKEY)) RegConnectRegistryA, - (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, TCHAR *, - DWORD, REGSAM, SECURITY_ATTRIBUTES *, HKEY *, - DWORD *)) RegCreateKeyExA, - (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteKeyA, - (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteValueA, - (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD)) RegEnumKeyA, - (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *, - TCHAR *, DWORD *, FILETIME *)) RegEnumKeyExA, - (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *, - DWORD *, BYTE *, DWORD *)) RegEnumValueA, - (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, REGSAM, - HKEY *)) RegOpenKeyExA, - (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD *, DWORD *, - BYTE *, DWORD *)) RegQueryValueExA, - (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, DWORD, - CONST BYTE*, DWORD)) RegSetValueExA, -}; - -static RegWinProcs unicodeProcs = { - 1, - - (LONG (WINAPI *)(CONST TCHAR *, HKEY, PHKEY)) RegConnectRegistryW, - (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, TCHAR *, - DWORD, REGSAM, SECURITY_ATTRIBUTES *, HKEY *, - DWORD *)) RegCreateKeyExW, - (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteKeyW, - (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteValueW, - (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD)) RegEnumKeyW, - (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *, - TCHAR *, DWORD *, FILETIME *)) RegEnumKeyExW, - (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *, - DWORD *, BYTE *, DWORD *)) RegEnumValueW, - (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, REGSAM, - HKEY *)) RegOpenKeyExW, - (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD *, DWORD *, - BYTE *, DWORD *)) RegQueryValueExW, - (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, DWORD, - CONST BYTE*, DWORD)) RegSetValueExW, -}; - - -/* * Declarations for functions defined in this file. */ static void AppendSystemError(Tcl_Interp *interp, DWORD error); static int BroadcastValue(Tcl_Interp *interp, int objc, - Tcl_Obj * CONST objv[]); + Tcl_Obj *const objv[]); static DWORD ConvertDWORD(DWORD type, DWORD value); static void DeleteCmd(ClientData clientData); -static int DeleteKey(Tcl_Interp *interp, Tcl_Obj *keyNameObj); +static int DeleteKey(Tcl_Interp *interp, Tcl_Obj *keyNameObj, + REGSAM mode); static int DeleteValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj, - Tcl_Obj *valueNameObj); + Tcl_Obj *valueNameObj, REGSAM mode); static int GetKeyNames(Tcl_Interp *interp, Tcl_Obj *keyNameObj, - Tcl_Obj *patternObj); + Tcl_Obj *patternObj, REGSAM mode); static int GetType(Tcl_Interp *interp, Tcl_Obj *keyNameObj, - Tcl_Obj *valueNameObj); + Tcl_Obj *valueNameObj, REGSAM mode); static int GetValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj, - Tcl_Obj *valueNameObj); + Tcl_Obj *valueNameObj, REGSAM mode); static int GetValueNames(Tcl_Interp *interp, Tcl_Obj *keyNameObj, - Tcl_Obj *patternObj); + Tcl_Obj *patternObj, REGSAM mode); static int OpenKey(Tcl_Interp *interp, Tcl_Obj *keyNameObj, REGSAM mode, int flags, HKEY *keyPtr); static DWORD OpenSubKey(char *hostName, HKEY rootKey, @@ -185,16 +116,16 @@ static int ParseKeyName(Tcl_Interp *interp, char *name, char **hostNamePtr, HKEY *rootKeyPtr, char **keyNamePtr); static DWORD RecursiveDeleteKey(HKEY hStartKey, - CONST TCHAR * pKeyName); + const TCHAR * pKeyName, REGSAM mode); static int RegistryObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, - Tcl_Obj * CONST objv[]); + Tcl_Obj *const objv[]); static int SetValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj, Tcl_Obj *valueNameObj, Tcl_Obj *dataObj, - Tcl_Obj *typeObj); + Tcl_Obj *typeObj, REGSAM mode); -EXTERN int Registry_Init(Tcl_Interp *interp); -EXTERN int Registry_Unload(Tcl_Interp *interp, int flags); +DLLEXPORT int Registry_Init(Tcl_Interp *interp); +DLLEXPORT int Registry_Unload(Tcl_Interp *interp, int flags); /* *---------------------------------------------------------------------- @@ -218,25 +149,14 @@ Registry_Init( { Tcl_Command cmd; - if (Tcl_InitStubs(interp, "8.1", 0) == NULL) { + if (Tcl_InitStubs(interp, "8.5", 0) == NULL) { return TCL_ERROR; } - /* - * Determine if the unicode interfaces are available and select the - * appropriate registry function table. - */ - - if (TclWinGetPlatformId() == VER_PLATFORM_WIN32_NT) { - regWinProcs = &unicodeProcs; - } else { - regWinProcs = &asciiProcs; - } - cmd = Tcl_CreateObjCommand(interp, "registry", RegistryObjCmd, - (ClientData)interp, DeleteCmd); - Tcl_SetAssocData(interp, REGISTRY_ASSOC_KEY, NULL, (ClientData)cmd); - return Tcl_PkgProvide(interp, "registry", "1.2.2"); + interp, DeleteCmd); + Tcl_SetAssocData(interp, REGISTRY_ASSOC_KEY, NULL, cmd); + return Tcl_PkgProvide(interp, "registry", "1.3.3"); } /* @@ -276,7 +196,7 @@ Registry_Unload( * Delete the originally registered command. */ - cmd = (Tcl_Command)Tcl_GetAssocData(interp, REGISTRY_ASSOC_KEY, NULL); + cmd = Tcl_GetAssocData(interp, REGISTRY_ASSOC_KEY, NULL); if (cmd != NULL) { Tcl_DeleteCommandFromToken(interp, cmd); } @@ -306,7 +226,8 @@ DeleteCmd( ClientData clientData) { Tcl_Interp *interp = clientData; - Tcl_SetAssocData(interp, REGISTRY_ASSOC_KEY, NULL, (ClientData)NULL); + + Tcl_SetAssocData(interp, REGISTRY_ASSOC_KEY, NULL, NULL); } /* @@ -330,89 +251,125 @@ RegistryObjCmd( ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ - Tcl_Obj * CONST objv[]) /* Argument values. */ + Tcl_Obj *const objv[]) /* Argument values. */ { - int index; - char *errString = NULL; + int n = 1; + int index, argc; + REGSAM mode = 0; + const char *errString = NULL; - static CONST char *subcommands[] = { + static const char *const subcommands[] = { "broadcast", "delete", "get", "keys", "set", "type", "values", NULL }; enum SubCmdIdx { BroadcastIdx, DeleteIdx, GetIdx, KeysIdx, SetIdx, TypeIdx, ValuesIdx }; + static const char *const modes[] = { + "-32bit", "-64bit", NULL + }; if (objc < 2) { - Tcl_WrongNumArgs(interp, objc, objv, "option ?arg arg ...?"); + wrongArgs: + Tcl_WrongNumArgs(interp, 1, objv, "?-32bit|-64bit? option ?arg ...?"); return TCL_ERROR; } - if (Tcl_GetIndexFromObj(interp, objv[1], subcommands, "option", 0, &index) - != TCL_OK) { + if (Tcl_GetString(objv[n])[0] == '-') { + if (Tcl_GetIndexFromObj(interp, objv[n++], modes, "mode", 0, + &index) != TCL_OK) { + return TCL_ERROR; + } + switch (index) { + case 0: /* -32bit */ + mode |= KEY_WOW64_32KEY; + break; + case 1: /* -64bit */ + mode |= KEY_WOW64_64KEY; + break; + } + if (objc < 3) { + goto wrongArgs; + } + } + + if (Tcl_GetIndexFromObj(interp, objv[n++], subcommands, "option", 0, + &index) != TCL_OK) { return TCL_ERROR; } + argc = (objc - n); switch (index) { case BroadcastIdx: /* broadcast */ - return BroadcastValue(interp, objc, objv); + if (argc == 1 || argc == 3) { + int res = BroadcastValue(interp, argc, objv + n); + + if (res != TCL_BREAK) { + return res; + } + } + errString = "keyName ?-timeout milliseconds?"; break; case DeleteIdx: /* delete */ - if (objc == 3) { - return DeleteKey(interp, objv[2]); - } else if (objc == 4) { - return DeleteValue(interp, objv[2], objv[3]); + if (argc == 1) { + return DeleteKey(interp, objv[n], mode); + } else if (argc == 2) { + return DeleteValue(interp, objv[n], objv[n+1], mode); } errString = "keyName ?valueName?"; break; case GetIdx: /* get */ - if (objc == 4) { - return GetValue(interp, objv[2], objv[3]); + if (argc == 2) { + return GetValue(interp, objv[n], objv[n+1], mode); } errString = "keyName valueName"; break; case KeysIdx: /* keys */ - if (objc == 3) { - return GetKeyNames(interp, objv[2], NULL); - } else if (objc == 4) { - return GetKeyNames(interp, objv[2], objv[3]); + if (argc == 1) { + return GetKeyNames(interp, objv[n], NULL, mode); + } else if (argc == 2) { + return GetKeyNames(interp, objv[n], objv[n+1], mode); } errString = "keyName ?pattern?"; break; case SetIdx: /* set */ - if (objc == 3) { + if (argc == 1) { HKEY key; /* * Create the key and then close it immediately. */ - if (OpenKey(interp, objv[2], KEY_ALL_ACCESS, 1, &key) != TCL_OK) { + mode |= KEY_ALL_ACCESS; + if (OpenKey(interp, objv[n], mode, 1, &key) != TCL_OK) { return TCL_ERROR; } RegCloseKey(key); return TCL_OK; - } else if (objc == 5 || objc == 6) { - Tcl_Obj *typeObj = (objc == 5) ? NULL : objv[5]; - return SetValue(interp, objv[2], objv[3], objv[4], typeObj); + } else if (argc == 3) { + return SetValue(interp, objv[n], objv[n+1], objv[n+2], NULL, + mode); + } else if (argc == 4) { + return SetValue(interp, objv[n], objv[n+1], objv[n+2], objv[n+3], + mode); } errString = "keyName ?valueName data ?type??"; break; case TypeIdx: /* type */ - if (objc == 4) { - return GetType(interp, objv[2], objv[3]); + if (argc == 2) { + return GetType(interp, objv[n], objv[n+1], mode); } errString = "keyName valueName"; break; case ValuesIdx: /* values */ - if (objc == 3) { - return GetValueNames(interp, objv[2], NULL); - } else if (objc == 4) { - return GetValueNames(interp, objv[2], objv[3]); + if (argc == 1) { + return GetValueNames(interp, objv[n], NULL, mode); + } else if (argc == 2) { + return GetValueNames(interp, objv[n], objv[n+1], mode); } errString = "keyName ?pattern?"; break; } - Tcl_WrongNumArgs(interp, 2, objv, errString); + Tcl_WrongNumArgs(interp, (mode ? 3 : 2), objv, errString); return TCL_ERROR; } @@ -435,33 +392,35 @@ RegistryObjCmd( static int DeleteKey( Tcl_Interp *interp, /* Current interpreter. */ - Tcl_Obj *keyNameObj) /* Name of key to delete. */ + Tcl_Obj *keyNameObj, /* Name of key to delete. */ + REGSAM mode) /* Mode flags to pass. */ { char *tail, *buffer, *hostName, *keyName; - CONST char *nativeTail; + const TCHAR *nativeTail; HKEY rootKey, subkey; DWORD result; - int length; Tcl_DString buf; + REGSAM saveMode = mode; /* * Find the parent of the key being deleted and open it. */ - keyName = Tcl_GetStringFromObj(keyNameObj, &length); - buffer = ckalloc((unsigned int) length + 1); + keyName = Tcl_GetString(keyNameObj); + buffer = Tcl_Alloc(keyNameObj->length + 1); strcpy(buffer, keyName); if (ParseKeyName(interp, buffer, &hostName, &rootKey, &keyName) != TCL_OK) { - ckfree(buffer); + Tcl_Free(buffer); return TCL_ERROR; } if (*keyName == '\0') { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "bad key: cannot delete root keys", -1)); - ckfree(buffer); + Tcl_SetObjResult(interp, + Tcl_NewStringObj("bad key: cannot delete root keys", -1)); + Tcl_SetErrorCode(interp, "WIN_REG", "DEL_ROOT_KEY", NULL); + Tcl_Free(buffer); return TCL_ERROR; } @@ -473,15 +432,15 @@ DeleteKey( keyName = NULL; } - result = OpenSubKey(hostName, rootKey, keyName, - KEY_ENUMERATE_SUB_KEYS | DELETE, 0, &subkey); + mode |= KEY_ENUMERATE_SUB_KEYS | DELETE; + result = OpenSubKey(hostName, rootKey, keyName, mode, 0, &subkey); if (result != ERROR_SUCCESS) { - ckfree(buffer); + Tcl_Free(buffer); if (result == ERROR_FILE_NOT_FOUND) { return TCL_OK; } - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "unable to delete key: ", -1)); + Tcl_SetObjResult(interp, + Tcl_NewStringObj("unable to delete key: ", -1)); AppendSystemError(interp, result); return TCL_ERROR; } @@ -491,7 +450,7 @@ DeleteKey( */ nativeTail = Tcl_WinUtfToTChar(tail, -1, &buf); - result = RecursiveDeleteKey(subkey, nativeTail); + result = RecursiveDeleteKey(subkey, nativeTail, saveMode); Tcl_DStringFree(&buf); if (result != ERROR_SUCCESS && result != ERROR_FILE_NOT_FOUND) { @@ -504,7 +463,7 @@ DeleteKey( } RegCloseKey(subkey); - ckfree(buffer); + Tcl_Free(buffer); return result; } @@ -528,11 +487,12 @@ static int DeleteValue( Tcl_Interp *interp, /* Current interpreter. */ Tcl_Obj *keyNameObj, /* Name of key. */ - Tcl_Obj *valueNameObj) /* Name of value to delete. */ + Tcl_Obj *valueNameObj, /* Name of value to delete. */ + REGSAM mode) /* Mode flags to pass. */ { HKEY key; char *valueName; - int length; + size_t length; DWORD result; Tcl_DString ds; @@ -540,19 +500,20 @@ DeleteValue( * Attempt to open the key for deletion. */ - if (OpenKey(interp, keyNameObj, KEY_SET_VALUE, 0, &key) - != TCL_OK) { + mode |= KEY_SET_VALUE; + if (OpenKey(interp, keyNameObj, mode, 0, &key) != TCL_OK) { return TCL_ERROR; } - valueName = Tcl_GetStringFromObj(valueNameObj, &length); + valueName = Tcl_GetString(valueNameObj); + length = valueNameObj->length; Tcl_WinUtfToTChar(valueName, length, &ds); - result = (*regWinProcs->regDeleteValueProc)(key, Tcl_DStringValue(&ds)); + result = RegDeleteValue(key, (const TCHAR *)Tcl_DStringValue(&ds)); Tcl_DStringFree(&ds); if (result != ERROR_SUCCESS) { - Tcl_AppendResult(interp, "unable to delete value \"", - Tcl_GetString(valueNameObj), "\" from key \"", - Tcl_GetString(keyNameObj), "\": ", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unable to delete value \"%s\" from key \"%s\": ", + Tcl_GetString(valueNameObj), Tcl_GetString(keyNameObj))); AppendSystemError(interp, result); result = TCL_ERROR; } else { @@ -585,11 +546,13 @@ static int GetKeyNames( Tcl_Interp *interp, /* Current interpreter. */ Tcl_Obj *keyNameObj, /* Key to enumerate. */ - Tcl_Obj *patternObj) /* Optional match pattern. */ + Tcl_Obj *patternObj, /* Optional match pattern. */ + REGSAM mode) /* Mode flags to pass. */ { - char *pattern; /* Pattern being matched against subkeys */ + const char *pattern; /* Pattern being matched against subkeys */ HKEY key; /* Handle to the key being examined */ - TCHAR buffer[MAX_KEY_LENGTH*2]; /* Buffer to hold the subkey name */ + TCHAR buffer[MAX_KEY_LENGTH]; + /* Buffer to hold the subkey name */ DWORD bufSize; /* Size of the buffer */ DWORD index; /* Position of the current subkey */ char *name; /* Subkey name */ @@ -603,40 +566,37 @@ GetKeyNames( pattern = NULL; } - /* Attempt to open the key for enumeration. */ + /* + * Attempt to open the key for enumeration. + */ - if (OpenKey(interp, keyNameObj, - KEY_QUERY_VALUE | KEY_ENUMERATE_SUB_KEYS, - 0, &key) != TCL_OK) { + mode |= KEY_QUERY_VALUE | KEY_ENUMERATE_SUB_KEYS; + if (OpenKey(interp, keyNameObj, mode, 0, &key) != TCL_OK) { return TCL_ERROR; } - /* Enumerate the subkeys */ + /* + * Enumerate the subkeys. + */ resultPtr = Tcl_NewObj(); for (index = 0;; ++index) { bufSize = MAX_KEY_LENGTH; - result = (*regWinProcs->regEnumKeyExProc) - (key, index, buffer, &bufSize, NULL, NULL, NULL, NULL); + result = RegEnumKeyEx(key, index, buffer, &bufSize, + NULL, NULL, NULL, NULL); if (result != ERROR_SUCCESS) { if (result == ERROR_NO_MORE_ITEMS) { result = TCL_OK; } else { - Tcl_SetObjResult(interp, Tcl_NewObj()); - Tcl_AppendResult(interp, - "unable to enumerate subkeys of \"", - Tcl_GetString(keyNameObj), "\": ", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unable to enumerate subkeys of \"%s\": ", + Tcl_GetString(keyNameObj))); AppendSystemError(interp, result); result = TCL_ERROR; } break; } - if (regWinProcs->useWide) { - Tcl_WinTCharToUtf((TCHAR *) buffer, bufSize * sizeof(WCHAR), &ds); - } else { - Tcl_WinTCharToUtf((TCHAR *) buffer, bufSize, &ds); - } - name = Tcl_DStringValue(&ds); + name = Tcl_WinTCharToUtf(buffer, bufSize * sizeof(TCHAR), &ds); if (pattern && !Tcl_StringMatch(name, pattern)) { Tcl_DStringFree(&ds); continue; @@ -679,22 +639,22 @@ static int GetType( Tcl_Interp *interp, /* Current interpreter. */ Tcl_Obj *keyNameObj, /* Name of key. */ - Tcl_Obj *valueNameObj) /* Name of value to get. */ + Tcl_Obj *valueNameObj, /* Name of value to get. */ + REGSAM mode) /* Mode flags to pass. */ { HKEY key; - DWORD result; - DWORD type; + DWORD result, type; Tcl_DString ds; - char *valueName; - CONST char *nativeValue; - int length; + const char *valueName; + const TCHAR *nativeValue; + size_t length; /* * Attempt to open the key for reading. */ - if (OpenKey(interp, keyNameObj, KEY_QUERY_VALUE, 0, &key) - != TCL_OK) { + mode |= KEY_QUERY_VALUE; + if (OpenKey(interp, keyNameObj, mode, 0, &key) != TCL_OK) { return TCL_ERROR; } @@ -702,17 +662,18 @@ GetType( * Get the type of the value. */ - valueName = Tcl_GetStringFromObj(valueNameObj, &length); + valueName = Tcl_GetString(valueNameObj); + length = valueNameObj->length; nativeValue = Tcl_WinUtfToTChar(valueName, length, &ds); - result = (*regWinProcs->regQueryValueExProc)(key, nativeValue, NULL, &type, + result = RegQueryValueEx(key, nativeValue, NULL, &type, NULL, NULL); Tcl_DStringFree(&ds); RegCloseKey(key); if (result != ERROR_SUCCESS) { - Tcl_AppendResult(interp, "unable to get type of value \"", - Tcl_GetString(valueNameObj), "\" from key \"", - Tcl_GetString(keyNameObj), "\": ", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unable to get type of value \"%s\" from key \"%s\": ", + Tcl_GetString(valueNameObj), Tcl_GetString(keyNameObj))); AppendSystemError(interp, result); return TCL_ERROR; } @@ -751,20 +712,22 @@ static int GetValue( Tcl_Interp *interp, /* Current interpreter. */ Tcl_Obj *keyNameObj, /* Name of key. */ - Tcl_Obj *valueNameObj) /* Name of value to get. */ + Tcl_Obj *valueNameObj, /* Name of value to get. */ + REGSAM mode) /* Mode flags to pass. */ { HKEY key; - char *valueName; - CONST char *nativeValue; + const char *valueName; + const TCHAR *nativeValue; DWORD result, length, type; Tcl_DString data, buf; - int nameLen; + size_t nameLen; /* * Attempt to open the key for reading. */ - if (OpenKey(interp, keyNameObj, KEY_QUERY_VALUE, 0, &key) != TCL_OK) { + mode |= KEY_QUERY_VALUE; + if (OpenKey(interp, keyNameObj, mode, 0, &key) != TCL_OK) { return TCL_ERROR; } @@ -780,12 +743,13 @@ GetValue( Tcl_DStringInit(&data); Tcl_DStringSetLength(&data, TCL_DSTRING_STATIC_SIZE - 1); - length = TCL_DSTRING_STATIC_SIZE / (regWinProcs->useWide ? 2 : 1) - 1; + length = TCL_DSTRING_STATIC_SIZE/sizeof(TCHAR) - 1; - valueName = Tcl_GetStringFromObj(valueNameObj, &nameLen); + valueName = Tcl_GetString(valueNameObj); + nameLen = valueNameObj->length; nativeValue = Tcl_WinUtfToTChar(valueName, nameLen, &buf); - result = (*regWinProcs->regQueryValueExProc)(key, nativeValue, NULL, &type, + result = RegQueryValueEx(key, nativeValue, NULL, &type, (BYTE *) Tcl_DStringValue(&data), &length); while (result == ERROR_MORE_DATA) { /* @@ -794,17 +758,17 @@ GetValue( * HKEY_PERFORMANCE_DATA */ - length = Tcl_DStringLength(&data) * (regWinProcs->useWide ? 1 : 2); - Tcl_DStringSetLength(&data, (int) length * (regWinProcs->useWide ? 2 : 1)); - result = (*regWinProcs->regQueryValueExProc)(key, (char *) nativeValue, + length = Tcl_DStringLength(&data) * (2 / sizeof(TCHAR)); + Tcl_DStringSetLength(&data, (int) length * sizeof(TCHAR)); + result = RegQueryValueEx(key, nativeValue, NULL, &type, (BYTE *) Tcl_DStringValue(&data), &length); } Tcl_DStringFree(&buf); RegCloseKey(key); if (result != ERROR_SUCCESS) { - Tcl_AppendResult(interp, "unable to get value \"", - Tcl_GetString(valueNameObj), "\" from key \"", - Tcl_GetString(keyNameObj), "\": ", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unable to get value \"%s\" from key \"%s\": ", + Tcl_GetString(valueNameObj), Tcl_GetString(keyNameObj))); AppendSystemError(interp, result); Tcl_DStringFree(&data); return TCL_ERROR; @@ -819,7 +783,7 @@ GetValue( if (type == REG_DWORD || type == REG_DWORD_BIG_ENDIAN) { Tcl_SetObjResult(interp, Tcl_NewIntObj((int) ConvertDWORD(type, - *((DWORD*) Tcl_DStringValue(&data))))); + *((DWORD *) Tcl_DStringValue(&data))))); } else if (type == REG_MULTI_SZ) { char *p = Tcl_DStringValue(&data); char *end = Tcl_DStringValue(&data) + length; @@ -831,19 +795,17 @@ GetValue( * we get bogus data. */ - while (p < end && ((regWinProcs->useWide) - ? *((Tcl_UniChar *)p) : *p) != 0) { + while ((p < end) && *((WCHAR *) p) != 0) { + WCHAR *wp; + Tcl_WinTCharToUtf((TCHAR *) p, -1, &buf); Tcl_ListObjAppendElement(interp, resultPtr, Tcl_NewStringObj(Tcl_DStringValue(&buf), Tcl_DStringLength(&buf))); - if (regWinProcs->useWide) { - Tcl_UniChar* up = (Tcl_UniChar*) p; - while (*up++ != 0) {} - p = (char*) up; - } else { - while (*p++ != '\0') {} - } + wp = (WCHAR *) p; + + while (*wp++ != 0) {/* empty body */} + p = (char *) wp; Tcl_DStringFree(&buf); } Tcl_SetObjResult(interp, resultPtr); @@ -885,27 +847,27 @@ static int GetValueNames( Tcl_Interp *interp, /* Current interpreter. */ Tcl_Obj *keyNameObj, /* Key to enumerate. */ - Tcl_Obj *patternObj) /* Optional match pattern. */ + Tcl_Obj *patternObj, /* Optional match pattern. */ + REGSAM mode) /* Mode flags to pass. */ { HKEY key; Tcl_Obj *resultPtr; DWORD index, size, result; Tcl_DString buffer, ds; - char *pattern, *name; + const char *pattern, *name; /* * Attempt to open the key for enumeration. */ - if (OpenKey(interp, keyNameObj, KEY_QUERY_VALUE, 0, &key) - != TCL_OK) { + mode |= KEY_QUERY_VALUE; + if (OpenKey(interp, keyNameObj, mode, 0, &key) != TCL_OK) { return TCL_ERROR; } resultPtr = Tcl_NewObj(); Tcl_DStringInit(&buffer); - Tcl_DStringSetLength(&buffer, - (int) ((regWinProcs->useWide) ? MAX_KEY_LENGTH*2 : MAX_KEY_LENGTH)); + Tcl_DStringSetLength(&buffer, (int) (MAX_KEY_LENGTH * sizeof(TCHAR))); index = 0; result = TCL_OK; @@ -922,13 +884,9 @@ GetValueNames( */ size = MAX_KEY_LENGTH; - while ((*regWinProcs->regEnumValueProc)(key, index, - Tcl_DStringValue(&buffer), &size, NULL, NULL, NULL, NULL) - == ERROR_SUCCESS) { - - if (regWinProcs->useWide) { - size *= 2; - } + while (RegEnumValue(key,index, (TCHAR *)Tcl_DStringValue(&buffer), + &size, NULL, NULL, NULL, NULL) == ERROR_SUCCESS) { + size *= sizeof(TCHAR); Tcl_WinTCharToUtf((TCHAR *) Tcl_DStringValue(&buffer), (int) size, &ds); @@ -978,12 +936,13 @@ OpenKey( HKEY *keyPtr) /* Returned HKEY. */ { char *keyName, *buffer, *hostName; - int length; + size_t length; HKEY rootKey; DWORD result; - keyName = Tcl_GetStringFromObj(keyNameObj, &length); - buffer = ckalloc((unsigned int) length + 1); + keyName = Tcl_GetString(keyNameObj); + length = keyNameObj->length; + buffer = Tcl_Alloc(length + 1); strcpy(buffer, keyName); result = ParseKeyName(interp, buffer, &hostName, &rootKey, &keyName); @@ -999,7 +958,7 @@ OpenKey( } } - ckfree(buffer); + Tcl_Free(buffer); return result; } @@ -1039,7 +998,7 @@ OpenSubKey( if (hostName) { hostName = (char *) Tcl_WinUtfToTChar(hostName, -1, &buf); - result = (*regWinProcs->regConnectRegistryProc)(hostName, rootKey, + result = RegConnectRegistry((TCHAR *)hostName, rootKey, &rootKey); Tcl_DStringFree(&buf); if (result != ERROR_SUCCESS) { @@ -1052,23 +1011,29 @@ OpenSubKey( * this key must be closed by the caller. */ - keyName = (char *) Tcl_WinUtfToTChar(keyName, -1, &buf); + if (keyName) { + keyName = (char *) Tcl_WinUtfToTChar(keyName, -1, &buf); + } if (flags & REG_CREATE) { DWORD create; - result = (*regWinProcs->regCreateKeyExProc)(rootKey, keyName, 0, NULL, + + result = RegCreateKeyEx(rootKey, (TCHAR *)keyName, 0, NULL, REG_OPTION_NON_VOLATILE, mode, NULL, keyPtr, &create); } else if (rootKey == HKEY_PERFORMANCE_DATA) { /* * Here we fudge it for this special root key. See MSDN for more info * on HKEY_PERFORMANCE_DATA and the peculiarities surrounding it. */ + *keyPtr = HKEY_PERFORMANCE_DATA; result = ERROR_SUCCESS; } else { - result = (*regWinProcs->regOpenKeyExProc)(rootKey, keyName, 0, mode, + result = RegOpenKeyEx(rootKey, (TCHAR *)keyName, 0, mode, keyPtr); } - Tcl_DStringFree(&buf); + if (keyName) { + Tcl_DStringFree(&buf); + } /* * Be sure to close the root key since we are done with it now. @@ -1129,8 +1094,9 @@ ParseKeyName( rootName = name; } if (!rootName) { - Tcl_AppendResult(interp, "bad key \"", name, - "\": must start with a valid root", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad key \"%s\": must start with a valid root", name)); + Tcl_SetErrorCode(interp, "WIN_REG", "NO_ROOT_KEY", NULL); return TCL_ERROR; } @@ -1182,12 +1148,16 @@ ParseKeyName( static DWORD RecursiveDeleteKey( HKEY startKey, /* Parent of key to be deleted. */ - CONST char *keyName) /* Name of key to be deleted in external + const TCHAR *keyName, /* Name of key to be deleted in external * encoding, not UTF. */ + REGSAM mode) /* Mode flags to pass. */ { DWORD result, size; Tcl_DString subkey; HKEY hKey; + REGSAM saveMode = mode; + static int checkExProc = 0; + static FARPROC regDeleteKeyExProc = NULL; /* * Do not allow NULL or empty key name. @@ -1197,29 +1167,48 @@ RecursiveDeleteKey( return ERROR_BADKEY; } - result = (*regWinProcs->regOpenKeyExProc)(startKey, keyName, 0, - KEY_ENUMERATE_SUB_KEYS | DELETE | KEY_QUERY_VALUE, &hKey); + mode |= KEY_ENUMERATE_SUB_KEYS | DELETE | KEY_QUERY_VALUE; + result = RegOpenKeyEx(startKey, keyName, 0, mode, &hKey); if (result != ERROR_SUCCESS) { return result; } Tcl_DStringInit(&subkey); - Tcl_DStringSetLength(&subkey, - (int) ((regWinProcs->useWide) ? MAX_KEY_LENGTH * 2 : MAX_KEY_LENGTH)); + Tcl_DStringSetLength(&subkey, (int) (MAX_KEY_LENGTH * sizeof(TCHAR))); + mode = saveMode; while (result == ERROR_SUCCESS) { /* * Always get index 0 because key deletion changes ordering. */ size = MAX_KEY_LENGTH; - result=(*regWinProcs->regEnumKeyExProc)(hKey, 0, - Tcl_DStringValue(&subkey), &size, NULL, NULL, NULL, NULL); + result = RegEnumKeyEx(hKey, 0, (TCHAR *)Tcl_DStringValue(&subkey), + &size, NULL, NULL, NULL, NULL); if (result == ERROR_NO_MORE_ITEMS) { - result = (*regWinProcs->regDeleteKeyProc)(startKey, keyName); + /* + * RegDeleteKeyEx doesn't exist on non-64bit XP platforms, so we + * can't compile with it in. We need to check for it at runtime + * and use it if we find it. + */ + + if (mode && !checkExProc) { + HMODULE handle; + + checkExProc = 1; + handle = GetModuleHandle(TEXT("ADVAPI32")); + regDeleteKeyExProc = (FARPROC) + GetProcAddress(handle, "RegDeleteKeyExW"); + } + if (mode && regDeleteKeyExProc) { + result = regDeleteKeyExProc(startKey, keyName, mode, 0); + } else { + result = RegDeleteKey(startKey, keyName); + } break; } else if (result == ERROR_SUCCESS) { - result = RecursiveDeleteKey(hKey, Tcl_DStringValue(&subkey)); + result = RecursiveDeleteKey(hKey, + (const TCHAR *) Tcl_DStringValue(&subkey), mode); } } Tcl_DStringFree(&subkey); @@ -1251,29 +1240,32 @@ SetValue( Tcl_Obj *keyNameObj, /* Name of key. */ Tcl_Obj *valueNameObj, /* Name of value to set. */ Tcl_Obj *dataObj, /* Data to be written. */ - Tcl_Obj *typeObj) /* Type of data to be written. */ + Tcl_Obj *typeObj, /* Type of data to be written. */ + REGSAM mode) /* Mode flags to pass. */ { int type; + size_t length; DWORD result; HKEY key; - int length; - char *valueName; + const char *valueName; Tcl_DString nameBuf; if (typeObj == NULL) { type = REG_SZ; } else if (Tcl_GetIndexFromObj(interp, typeObj, typeNames, "type", 0, (int *) &type) != TCL_OK) { - if (Tcl_GetIntFromObj(NULL, typeObj, (int*) &type) != TCL_OK) { + if (Tcl_GetIntFromObj(NULL, typeObj, (int *) &type) != TCL_OK) { return TCL_ERROR; } Tcl_ResetResult(interp); } - if (OpenKey(interp, keyNameObj, KEY_ALL_ACCESS, 1, &key) != TCL_OK) { + mode |= KEY_ALL_ACCESS; + if (OpenKey(interp, keyNameObj, mode, 1, &key) != TCL_OK) { return TCL_ERROR; } - valueName = Tcl_GetStringFromObj(valueNameObj, &length); + valueName = Tcl_GetString(valueNameObj); + length = valueNameObj->length; valueName = (char *) Tcl_WinUtfToTChar(valueName, length, &nameBuf); if (type == REG_DWORD || type == REG_DWORD_BIG_ENDIAN) { @@ -1285,8 +1277,8 @@ SetValue( return TCL_ERROR; } - value = ConvertDWORD((DWORD)type, (DWORD)value); - result = (*regWinProcs->regSetValueExProc)(key, valueName, 0, + value = ConvertDWORD((DWORD) type, (DWORD) value); + result = RegSetValueEx(key, (TCHAR *) valueName, 0, (DWORD) type, (BYTE *) &value, sizeof(DWORD)); } else if (type == REG_MULTI_SZ) { Tcl_DString data, buf; @@ -1307,53 +1299,53 @@ SetValue( Tcl_DStringInit(&data); for (i = 0; i < objc; i++) { - Tcl_DStringAppend(&data, Tcl_GetString(objv[i]), -1); + const char *bytes = Tcl_GetString(objv[i]); + + length = objv[i]->length; + Tcl_DStringAppend(&data, bytes, length); /* - * Add a null character to separate this value from the next. We - * accomplish this by growing the string by one byte. Since the - * DString always tacks on an extra null byte, the new byte will - * already be set to null. + * Add a null character to separate this value from the next. */ - Tcl_DStringSetLength(&data, Tcl_DStringLength(&data)+1); + Tcl_DStringAppend(&data, "", 1); /* NUL-terminated string */ } Tcl_WinUtfToTChar(Tcl_DStringValue(&data), Tcl_DStringLength(&data)+1, &buf); - result = (*regWinProcs->regSetValueExProc)(key, valueName, 0, - (DWORD) type, (BYTE *) Tcl_DStringValue(&buf), + result = RegSetValueEx(key, (TCHAR *) valueName, 0, + (DWORD) type, (BYTE *) Tcl_DStringValue(&buf), (DWORD) Tcl_DStringLength(&buf)); Tcl_DStringFree(&data); Tcl_DStringFree(&buf); } else if (type == REG_SZ || type == REG_EXPAND_SZ) { Tcl_DString buf; - CONST char *data = Tcl_GetStringFromObj(dataObj, &length); + const char *data = Tcl_GetString(dataObj); - data = Tcl_WinUtfToTChar(data, length, &buf); + length = dataObj->length; + data = (char *) Tcl_WinUtfToTChar(data, length, &buf); /* - * Include the null in the length, padding if needed for Unicode. + * Include the null in the length, padding if needed for WCHAR. */ - if (regWinProcs->useWide) { - Tcl_DStringSetLength(&buf, Tcl_DStringLength(&buf)+1); - } + Tcl_DStringSetLength(&buf, Tcl_DStringLength(&buf)+1); length = Tcl_DStringLength(&buf) + 1; - result = (*regWinProcs->regSetValueExProc)(key, valueName, 0, - (DWORD) type, (BYTE *) data, (DWORD) length); + result = RegSetValueEx(key, (TCHAR *) valueName, 0, + (DWORD) type, (BYTE *) data, (DWORD) length); Tcl_DStringFree(&buf); } else { BYTE *data; + int bytelength; /* * Store binary data in the registry. */ - data = (BYTE *) Tcl_GetByteArrayFromObj(dataObj, &length); - result = (*regWinProcs->regSetValueExProc)(key, valueName, 0, - (DWORD) type, data, (DWORD) length); + data = (BYTE *) Tcl_GetByteArrayFromObj(dataObj, &bytelength); + result = RegSetValueEx(key, (TCHAR *) valueName, 0, + (DWORD) type, data, (DWORD) bytelength); } Tcl_DStringFree(&nameBuf); @@ -1389,35 +1381,33 @@ static int BroadcastValue( Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ - Tcl_Obj *CONST objv[]) /* Argument values. */ + Tcl_Obj *const objv[]) /* Argument values. */ { LRESULT result; DWORD_PTR sendResult; - UINT timeout = 3000; - int len; - CONST char *str; + int timeout = 3000; + size_t len; + const char *str; Tcl_Obj *objPtr; + WCHAR *wstr; + Tcl_DString ds; - if ((objc != 3) && (objc != 5)) { - Tcl_WrongNumArgs(interp, 2, objv, "keyName ?-timeout millisecs?"); - return TCL_ERROR; - } - - if (objc > 3) { - str = Tcl_GetStringFromObj(objv[3], &len); - if ((len < 2) || (*str != '-') - || strncmp(str, "-timeout", (size_t) len)) { - Tcl_WrongNumArgs(interp, 2, objv, "keyName ?-timeout millisecs?"); - return TCL_ERROR; + if (objc == 3) { + str = Tcl_GetString(objv[1]); + len = objv[1]->length; + if ((len < 2) || (*str != '-') || strncmp(str, "-timeout", len)) { + return TCL_BREAK; } - if (Tcl_GetIntFromObj(interp, objv[4], (int *) &timeout) != TCL_OK) { + if (Tcl_GetIntFromObj(interp, objv[2], &timeout) != TCL_OK) { return TCL_ERROR; } } - str = Tcl_GetStringFromObj(objv[2], &len); - if (len == 0) { - str = NULL; + str = Tcl_GetString(objv[0]); + len = objv[0]->length; + wstr = (WCHAR *) Tcl_WinUtfToTChar(str, len, &ds); + if (Tcl_DStringLength(&ds) == 0) { + wstr = NULL; } /* @@ -1425,11 +1415,12 @@ BroadcastValue( */ result = SendMessageTimeout(HWND_BROADCAST, WM_SETTINGCHANGE, - (WPARAM) 0, (LPARAM) str, SMTO_ABORTIFHUNG, timeout, &sendResult); + (WPARAM) 0, (LPARAM) wstr, SMTO_ABORTIFHUNG, (UINT) timeout, &sendResult); + Tcl_DStringFree(&ds); objPtr = Tcl_NewObj(); - Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewLongObj((long) result)); - Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewLongObj((long) sendResult)); + Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewWideIntObj((Tcl_WideInt) result)); + Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewWideIntObj((Tcl_WideInt) sendResult)); Tcl_SetObjResult(interp, objPtr); return TCL_OK; @@ -1458,8 +1449,8 @@ AppendSystemError( DWORD error) /* Result code from error. */ { int length; - WCHAR *wMsgPtr, **wMsgPtrPtr = &wMsgPtr; - char *msg; + TCHAR *tMsgPtr, **tMsgPtrPtr = &tMsgPtr; + const char *msg; char id[TCL_INTEGER_SPACE], msgBuf[24 + TCL_INTEGER_SPACE]; Tcl_DString ds; Tcl_Obj *resultPtr = Tcl_GetObjResult(interp); @@ -1467,52 +1458,34 @@ AppendSystemError( if (Tcl_IsShared(resultPtr)) { resultPtr = Tcl_DuplicateObj(resultPtr); } - length = FormatMessageW(FORMAT_MESSAGE_FROM_SYSTEM + length = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_ALLOCATE_BUFFER, NULL, error, - MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (WCHAR *) wMsgPtrPtr, + MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (TCHAR *) tMsgPtrPtr, 0, NULL); if (length == 0) { - char *msgPtr; - - length = FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM - | FORMAT_MESSAGE_ALLOCATE_BUFFER, NULL, error, - MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (char *) &msgPtr, - 0, NULL); - if (length > 0) { - wMsgPtr = (WCHAR *) LocalAlloc(LPTR, (length + 1) * sizeof(WCHAR)); - MultiByteToWideChar(CP_ACP, 0, msgPtr, length + 1, wMsgPtr, - length + 1); - LocalFree(msgPtr); - } - } - if (length == 0) { - if (error == ERROR_CALL_NOT_IMPLEMENTED) { - msg = "function not supported under Win32s"; - } else { - sprintf(msgBuf, "unknown error: %ld", error); - msg = msgBuf; - } + sprintf(msgBuf, "unknown error: %ld", error); + msg = msgBuf; } else { - Tcl_Encoding encoding; + char *msgPtr; - encoding = Tcl_GetEncoding(NULL, "unicode"); - Tcl_ExternalToUtfDString(encoding, (char *) wMsgPtr, -1, &ds); - Tcl_FreeEncoding(encoding); - LocalFree(wMsgPtr); + Tcl_WinTCharToUtf(tMsgPtr, -1, &ds); + LocalFree(tMsgPtr); - msg = Tcl_DStringValue(&ds); + msgPtr = Tcl_DStringValue(&ds); length = Tcl_DStringLength(&ds); /* * Trim the trailing CR/LF from the system message. */ - if (msg[length-1] == '\n') { - msg[--length] = 0; + if (msgPtr[length-1] == '\n') { + --length; } - if (msg[length-1] == '\r') { - msg[--length] = 0; + if (msgPtr[length-1] == '\r') { + --length; } + msgPtr[length] = 0; + msg = msgPtr; } sprintf(id, "%ld", error); @@ -1547,14 +1520,15 @@ ConvertDWORD( DWORD type, /* Either REG_DWORD or REG_DWORD_BIG_ENDIAN */ DWORD value) /* The value to be converted. */ { - DWORD order = 1; + const DWORD order = 1; DWORD localType; /* * Check to see if the low bit is in the first byte. */ - localType = (*((char*) &order) == 1) ? REG_DWORD : REG_DWORD_BIG_ENDIAN; + localType = (*((const char *) &order) == 1) + ? REG_DWORD : REG_DWORD_BIG_ENDIAN; return (type != localType) ? (DWORD) SWAPLONG(value) : value; } -- cgit v0.12 From 63802cdd705ae32157c199f729c6ee2e61501e6e Mon Sep 17 00:00:00 2001 From: pspjuth Date: Wed, 24 Oct 2018 22:15:50 +0000 Subject: Simplify to only accept index arguemnts. No index list. Added manual page. --- doc/lpop.n | 96 ++++++++++++++++++++++++++++++++++++++++++++++++++++ generic/tclCmdIL.c | 15 +++----- generic/tclListObj.c | 13 ++----- tests/lpop.test | 14 +++++--- 4 files changed, 112 insertions(+), 26 deletions(-) create mode 100644 doc/lpop.n diff --git a/doc/lpop.n b/doc/lpop.n new file mode 100644 index 0000000..0ce8ff8 --- /dev/null +++ b/doc/lpop.n @@ -0,0 +1,96 @@ +'\" +'\" Copyright (c) 2018 by Peter Spjuth. All rights reserved. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +.TH lpop n 8.7 Tcl "Tcl Built-In Commands" +.so man.macros +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +lpop \- Get and remove an element in a list +.SH SYNOPSIS +\fBlpop \fIvarName ?index ...?\fR +.BE +.SH DESCRIPTION +.PP +The \fBlpop\fR command accepts a parameter, \fIvarName\fR, which +it interprets as the name of a variable containing a Tcl list. +It also accepts one or more \fIindices\fR into +the list. If no indices are presented, it defaults to "end". +.PP +When presented with a single index, the \fBlpop\fR command +addresses the \fIindex\fR'th element in it, removes if from the list +and returns the element. +.PP +If \fIindex\fR is negative or greater or equal than the number +of elements in \fI$varName\fR, then an error occurs. +.PP +The interpretation of each simple \fIindex\fR value is the same as +for the command \fBstring index\fR, supporting simple index +arithmetic and indices relative to the end of the list. +.PP +If additional \fIindex\fR arguments are supplied, then each argument is +used in turn to address an element within a sublist designated +by the previous indexing operation, +allowing the script to remove elements in sublists. +The command, +.PP +.CS +\fBlpop\fR a 1 2 +.CE +.PP +gets and removes element 2 of sublist 1. +.PP +.SH EXAMPLES +.PP +In each of these examples, the initial value of \fIx\fR is: +.PP +.CS +set x [list [list a b c] [list d e f] [list g h i]] + \fI\(-> {a b c} {d e f} {g h i}\fR +.CE +.PP +The indicated value becomes the new value of \fIx\fR +(except in the last case, which is an error which leaves the value of +\fIx\fR unchanged.) +.PP +.CS +\fBlpop\fR x 0 + \fI\(-> {d e f} {g h i}\fR +\fBlpop\fR x 2 + \fI\(-> {a b c} {d e f}\fR +\fBlpop\fR x end + \fI\(-> {a b c} {d e f}\fR +\fBlpop\fR x end-1 + \fI\(-> {a b c} {g h i}\fR +\fBlpop\fR x 2 1 + \fI\(-> {a b c} {d e f} {g i}\fR +\fBlpop\fR x 2 3 j + \fI\(-> list index out of range\fR +.CE +.PP +In the following examples, the initial value of \fIx\fR is: +.PP +.CS +set x [list [list [list a b] [list c d]] \e + [list [list e f] [list g h]]] + \fI\(-> {{a b} {c d}} {{e f} {g h}}\fR +.CE +.PP +The indicated value becomes the new value of \fIx\fR. +.PP +.CS +\fBlpop\fR x 1 1 0 + \fI\(-> {{a b} {c d}} {{e f} h}\fR +.CE +.SH "SEE ALSO" +list(n), lappend(n), lindex(n), linsert(n), llength(n), lsearch(n), +lsort(n), lrange(n), lreplace(n), lset(n) +string(n) +.SH KEYWORDS +element, index, list, remove, pop, stack, queue +'\"Local Variables: +'\"mode: nroff +'\"End: diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index fb19a3f..9c717bf 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -2614,18 +2614,14 @@ Tcl_LpopObjCmd( /* * First, extract the element to be returned. - * TclLindex* adds a ref count which is handled. + * TclLindexFlat adds a ref count which is handled. */ if (objc == 2) { elemPtr = elemPtrs[listLen - 1]; Tcl_IncrRefCount(elemPtr); } else { - if (objc == 3) { - elemPtr = TclLindexList(interp, listPtr, objv[2]); - } else { - elemPtr = TclLindexFlat(interp, listPtr, objc-2, objv+2); - } + elemPtr = TclLindexFlat(interp, listPtr, objc-2, objv+2); if (elemPtr == NULL) { return TCL_ERROR; @@ -2647,11 +2643,8 @@ Tcl_LpopObjCmd( return result; } } else { - if (objc == 3) { - listPtr = TclLsetList(interp, listPtr, objv[2], NULL); - } else { - listPtr = TclLsetFlat(interp, listPtr, objc-2, objv+2, NULL); - } + listPtr = TclLsetFlat(interp, listPtr, objc-2, objv+2, NULL); + if (listPtr == NULL) { return TCL_ERROR; } diff --git a/generic/tclListObj.c b/generic/tclListObj.c index be05873..70996ef 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -1485,20 +1485,13 @@ TclLsetFlat( /* * If there are no indices, simply return the new value. (Without * indices, [lset] is a synonym for [set]. - * This is an error for [lpop]. + * [lpop] does not use this but protect for NULL valuePtr just in case. */ if (indexCount == 0) { - if (valuePtr == NULL) { - if (interp != NULL) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("list index out of range", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LPOP", - "BADINDEX", NULL); - } - return NULL; + if (valuePtr != NULL) { + Tcl_IncrRefCount(valuePtr); } - Tcl_IncrRefCount(valuePtr); return valuePtr; } diff --git a/tests/lpop.test b/tests/lpop.test index 7f0c6a8..089299b 100644 --- a/tests/lpop.test +++ b/tests/lpop.test @@ -41,11 +41,15 @@ test lpop-1.6 {error conditions} -returnCodes error -body { test lpop-1.7 {error conditions} -returnCodes error -body { set no "x y" lpop no {} -} -result {list index out of range} +} -match glob -result {bad index *} test lpop-1.8 {error conditions} -returnCodes error -body { set no "x y" - lpop no {0 0 0 0 1} + lpop no 0 0 0 0 1 } -result {list index out of range} +test lpop-1.9 {error conditions} -returnCodes error -body { + set no "x y" + lpop no {1 0} +} -match glob -result {bad index *} test lpop-2.1 {basic functionality} -body { set l "x y z" @@ -68,15 +72,15 @@ test lpop-2.4 {basic functionality} -body { test lpop-3.1 {nested} -body { set l "x y" set l2 $l - list [lpop l {0 0 0 0}] $l $l2 + list [lpop l 0 0 0 0] $l $l2 } -result {x {{{{}}} y} {x y}} test lpop-3.2 {nested} -body { set l "{x y} {a b}" - list [lpop l {0 1}] $l + list [lpop l 0 1] $l } -result {y {x {a b}}} test lpop-3.3 {nested} -body { set l "{x y} {a b}" - list [lpop l {1 0}] $l + list [lpop l 1 0] $l } -result {a {{x y} b}} -- cgit v0.12 From b28e8c3bd12a7bf36eb2745b105c36901403b6c2 Mon Sep 17 00:00:00 2001 From: dgp Date: Sat, 27 Oct 2018 01:04:33 +0000 Subject: Draft implementation of TIP 506 - rebased to Tcl 8.7 --- generic/tcl.decls | 14 +++++++++++- generic/tcl.h | 30 +++---------------------- generic/tclDecls.h | 20 +++++++++++++++-- generic/tclObj.c | 62 +++++++++++++++++++++++++++++++++++++++++++++++++++ generic/tclStubInit.c | 3 +++ 5 files changed, 99 insertions(+), 30 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index dfcb822..8f6bd06 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -132,7 +132,7 @@ declare 28 { declare 29 { Tcl_Obj *Tcl_DuplicateObj(Tcl_Obj *objPtr) } -declare 30 { +declare 30 {deprecated {Kept only for deployed refcounting macros}} { void TclFreeObj(Tcl_Obj *objPtr) } declare 31 { @@ -2346,6 +2346,18 @@ declare 635 { unsigned char *data, size_t datalen, int copy) } +declare 636 { + void Tcl_IncrRefCount(Tcl_Obj *objPtr) +} + +declare 637 { + void Tcl_DecrRefCount(Tcl_Obj *objPtr) +} + +declare 638 { + int Tcl_IsShared(Tcl_Obj *objPtr) +} + # ----- BASELINE -- FOR -- 8.7.0 ----- # ############################################################################## diff --git a/generic/tcl.h b/generic/tcl.h index 0971066..4e5c783 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -798,17 +798,6 @@ typedef struct Tcl_Obj { } internalRep; } Tcl_Obj; -/* - * Macros to increment and decrement a Tcl_Obj's reference count, and to test - * whether an object is shared (i.e. has reference count > 1). Note: clients - * should use Tcl_DecrRefCount() when they are finished using an object, and - * should never call TclFreeObj() directly. TclFreeObj() is only defined and - * made public in tcl.h to support Tcl_DecrRefCount's macro definition. - */ - -void Tcl_IncrRefCount(Tcl_Obj *objPtr); -void Tcl_DecrRefCount(Tcl_Obj *objPtr); -int Tcl_IsShared(Tcl_Obj *objPtr); /* *---------------------------------------------------------------------------- @@ -2482,28 +2471,15 @@ EXTERN int TclZipfs_AppHook(int *argc, char ***argv); #endif /* !TCL_MEM_DEBUG */ #ifdef TCL_MEM_DEBUG +# undef Tcl_IncrRefCount # define Tcl_IncrRefCount(objPtr) \ Tcl_DbIncrRefCount(objPtr, __FILE__, __LINE__) +# undef Tcl_DecrRefCount # define Tcl_DecrRefCount(objPtr) \ Tcl_DbDecrRefCount(objPtr, __FILE__, __LINE__) +# undef Tcl_IsShared # define Tcl_IsShared(objPtr) \ Tcl_DbIsShared(objPtr, __FILE__, __LINE__) -#else -# define Tcl_IncrRefCount(objPtr) \ - ++(objPtr)->refCount - /* - * Use do/while0 idiom for optimum correctness without compiler warnings. - * http://c2.com/cgi/wiki?TrivialDoWhileLoop - */ -# define Tcl_DecrRefCount(objPtr) \ - do { \ - Tcl_Obj *_objPtr = (objPtr); \ - if ((_objPtr)->refCount-- <= 1) { \ - TclFreeObj(_objPtr); \ - } \ - } while(0) -# define Tcl_IsShared(objPtr) \ - ((objPtr)->refCount > 1) #endif /* diff --git a/generic/tclDecls.h b/generic/tclDecls.h index e20782e..b96eabf 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -143,7 +143,8 @@ EXTERN Tcl_Obj * Tcl_DbNewStringObj(const char *bytes, int length, /* 29 */ EXTERN Tcl_Obj * Tcl_DuplicateObj(Tcl_Obj *objPtr); /* 30 */ -EXTERN void TclFreeObj(Tcl_Obj *objPtr); +TCL_DEPRECATED("Kept only for deployed refcounting macros") +void TclFreeObj(Tcl_Obj *objPtr); /* 31 */ EXTERN int Tcl_GetBoolean(Tcl_Interp *interp, const char *src, int *boolPtr); @@ -1875,6 +1876,12 @@ EXTERN Tcl_Obj * TclZipfs_TclLibrary(void); EXTERN int TclZipfs_MountBuffer(Tcl_Interp *interp, const char *mountPoint, unsigned char *data, size_t datalen, int copy); +/* 636 */ +EXTERN void Tcl_IncrRefCount(Tcl_Obj *objPtr); +/* 637 */ +EXTERN void Tcl_DecrRefCount(Tcl_Obj *objPtr); +/* 638 */ +EXTERN int Tcl_IsShared(Tcl_Obj *objPtr); typedef struct { const struct TclPlatStubs *tclPlatStubs; @@ -1932,7 +1939,7 @@ typedef struct TclStubs { Tcl_Obj * (*tcl_DbNewObj) (const char *file, int line); /* 27 */ Tcl_Obj * (*tcl_DbNewStringObj) (const char *bytes, int length, const char *file, int line); /* 28 */ Tcl_Obj * (*tcl_DuplicateObj) (Tcl_Obj *objPtr); /* 29 */ - void (*tclFreeObj) (Tcl_Obj *objPtr); /* 30 */ + TCL_DEPRECATED_API("Kept only for deployed refcounting macros") void (*tclFreeObj) (Tcl_Obj *objPtr); /* 30 */ int (*tcl_GetBoolean) (Tcl_Interp *interp, const char *src, int *boolPtr); /* 31 */ int (*tcl_GetBooleanFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *boolPtr); /* 32 */ unsigned char * (*tcl_GetByteArrayFromObj) (Tcl_Obj *objPtr, int *lengthPtr); /* 33 */ @@ -2546,6 +2553,9 @@ typedef struct TclStubs { int (*tclZipfs_Unmount) (Tcl_Interp *interp, const char *mountPoint); /* 633 */ Tcl_Obj * (*tclZipfs_TclLibrary) (void); /* 634 */ int (*tclZipfs_MountBuffer) (Tcl_Interp *interp, const char *mountPoint, unsigned char *data, size_t datalen, int copy); /* 635 */ + void (*tcl_IncrRefCount) (Tcl_Obj *objPtr); /* 636 */ + void (*tcl_DecrRefCount) (Tcl_Obj *objPtr); /* 637 */ + int (*tcl_IsShared) (Tcl_Obj *objPtr); /* 638 */ } TclStubs; extern const TclStubs *tclStubsPtr; @@ -3848,6 +3858,12 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tclZipfs_TclLibrary) /* 634 */ #define TclZipfs_MountBuffer \ (tclStubsPtr->tclZipfs_MountBuffer) /* 635 */ +#define Tcl_IncrRefCount \ + (tclStubsPtr->tcl_IncrRefCount) /* 636 */ +#define Tcl_DecrRefCount \ + (tclStubsPtr->tcl_DecrRefCount) /* 637 */ +#define Tcl_IsShared \ + (tclStubsPtr->tcl_IsShared) /* 638 */ #endif /* defined(USE_TCL_STUBS) */ diff --git a/generic/tclObj.c b/generic/tclObj.c index 5a8ce3b..137bf8a 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -3658,6 +3658,68 @@ TclGetNumberFromObj( /* *---------------------------------------------------------------------- * + * Tcl_IncrRefCount -- + * + * Increments the reference count of the object. + * + * Results: + * None. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_IncrRefCount( + Tcl_Obj *objPtr) /* The object we are registering a reference to. */ +{ + ++(objPtr)->refCount; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DecrRefCount -- + * + * Decrements the reference count of the object. + * + * Results: + * None. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DecrRefCount( + Tcl_Obj *objPtr) /* The object we are releasing a reference to. */ +{ + if (objPtr->refCount-- <= 1) { + TclFreeObj(objPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_IsShared -- + * + * Tests if the object has a ref count greater than one. + * + * Results: + * Boolean value that is the result of the test. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_IsShared( + Tcl_Obj *objPtr) /* The object to test for being shared. */ +{ + return ((objPtr)->refCount > 1); +} + +/* + *---------------------------------------------------------------------- + * * Tcl_DbIncrRefCount -- * * This function is normally called when debugging: i.e., when diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 6a4eabc..ec087a4 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -1581,6 +1581,9 @@ const TclStubs tclStubs = { TclZipfs_Unmount, /* 633 */ TclZipfs_TclLibrary, /* 634 */ TclZipfs_MountBuffer, /* 635 */ + Tcl_IncrRefCount, /* 636 */ + Tcl_DecrRefCount, /* 637 */ + Tcl_IsShared, /* 638 */ }; /* !END!: Do not edit above this line. */ -- cgit v0.12 From 9654f8c692e08a81dc7e45dd3a5a9e1c8f949596 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 27 Oct 2018 07:53:45 +0000 Subject: tclWinDde.c: Backport version 1.4.1 from Tcl 8.6. --- library/dde/pkgIndex.tcl | 4 +- tests/winDde.test | 290 +++++++++++++---------- win/Makefile.in | 6 +- win/configure | 8 +- win/configure.in | 4 +- win/makefile.bc | 4 +- win/makefile.vc | 4 +- win/tclWinDde.c | 583 +++++++++++++++++++++++++++++++---------------- win/tclWinReg.c | 32 +-- 9 files changed, 580 insertions(+), 355 deletions(-) diff --git a/library/dde/pkgIndex.tcl b/library/dde/pkgIndex.tcl index 114dee6..065dc83 100644 --- a/library/dde/pkgIndex.tcl +++ b/library/dde/pkgIndex.tcl @@ -1,7 +1,7 @@ if {![package vsatisfies [package provide Tcl] 8]} return if {[info sharedlibextension] != ".dll"} return if {[info exists ::tcl_platform(debug)]} { - package ifneeded dde 1.3.3 [list load [file join $dir tcldde13g.dll] dde] + package ifneeded dde 1.4.1 [list load [file join $dir tcldde14g.dll] dde] } else { - package ifneeded dde 1.3.3 [list load [file join $dir tcldde13.dll] dde] + package ifneeded dde 1.4.1 [list load [file join $dir tcldde14.dll] dde] } diff --git a/tests/winDde.test b/tests/winDde.test index f0ef56c..1fa7e86 100644 --- a/tests/winDde.test +++ b/tests/winDde.test @@ -9,18 +9,19 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 #tcltest::configure -verbose {pass start} namespace import -force ::tcltest::* } +testConstraint debug [::tcl::pkgconfig get debug] testConstraint dde 0 if {[testConstraint win]} { if {![catch { ::tcltest::loadTestedCommands - package require dde - set ::ddelib [lindex [package ifneeded dde 1.3.3] 1]}]} { + set ::ddever [package require dde 1.4.1] + set ::ddelib [lindex [package ifneeded dde $::ddever] 1]}]} { testConstraint dde 1 } } @@ -32,7 +33,7 @@ if {[testConstraint win]} { set scriptName [makeFile {} script1.tcl] -proc createChildProcess {ddeServerName {handler {}}} { +proc createChildProcess {ddeServerName args} { file delete -force $::scriptName set f [open $::scriptName w+] @@ -41,11 +42,11 @@ proc createChildProcess {ddeServerName {handler {}}} { puts $f { # DDE child server - # - if {[lsearch [namespace children] ::tcltest] == -1} { + if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } - + # If an error occurs during the tests, this process may end up not # being closed down. To deal with this we create a 30s timeout. proc ::DoTimeout {} { @@ -55,16 +56,19 @@ proc createChildProcess {ddeServerName {handler {}}} { flush stdout } set timeout [after 30000 ::DoTimeout] - + # Define a restricted handler. proc Handler1 {cmd} { if {$cmd eq "stop"} {set ::done 1} - puts $cmd ; flush stdout + if {$cmd == ""} { + set cmd "null data" + } + puts $cmd ; flush stdout return } proc Handler2 {cmd} { if {$cmd eq "stop"} {set ::done 1} - puts [uplevel \#0 $cmd] ; flush stdout + puts [uplevel \#0 $cmd] ; flush stdout return } proc Handler3 {prefix cmd} { @@ -74,11 +78,7 @@ proc createChildProcess {ddeServerName {handler {}}} { } } # set the dde server name to the supplied argument. - if {$handler == {}} { - puts $f [list dde servername $ddeServerName] - } else { - puts $f [list dde servername -handler $handler -- $ddeServerName] - } + puts $f [list dde servername {*}$args -- $ddeServerName] puts $f { # run the server and handle final cleanup. after 200;# give dde a chance to get going. @@ -88,12 +88,12 @@ proc createChildProcess {ddeServerName {handler {}}} { # allow enough time for the calling process to # claim all results, to avoid spurious "server did # not respond" - after 200 { set reallyDone 1 } + after 200 {set reallyDone 1} vwait reallyDone exit } close $f - + # run the child server script. set f [open |[list [interpreter] $::scriptName] r] fconfigure $f -buffering line @@ -102,147 +102,184 @@ proc createChildProcess {ddeServerName {handler {}}} { } # ------------------------------------------------------------------------- +test winDde-1.0 {check if we are testing the right dll} {win dde} { + set ::ddever +} {1.4.1} -test winDde-1.1 {Settings the server's topic name} {win dde} { +test winDde-1.1 {Settings the server's topic name} -constraints dde -body { list [dde servername foobar] [dde servername] [dde servername self] -} {foobar foobar self} +} -result {foobar foobar self} -test winDde-2.1 {Checking for other services} {win dde} { +test winDde-2.1 {Checking for other services} -constraints dde -body { expr [llength [dde services {} {}]] >= 0 -} 1 +} -result 1 test winDde-2.2 {Checking for existence, with service and topic specified} \ - {win dde} { + -constraints dde -body { llength [dde services TclEval self] -} 1 +} -result 1 test winDde-2.3 {Checking for existence, with only the service specified} \ - {win dde} { + -constraints dde -body { expr [llength [dde services TclEval {}]] >= 1 -} 1 +} -result 1 test winDde-2.4 {Checking for existence, with only the topic specified} \ - {win dde} { + -constraints dde -body { expr [llength [dde services {} self]] >= 1 -} 1 +} -result 1 # ------------------------------------------------------------------------- -test winDde-3.1 {DDE execute locally} {win dde} { - set a "" - dde execute TclEval self {set a "foo"} - set a -} foo -test winDde-3.2 {DDE execute -async locally} {win dde} { - set a "" - dde execute -async TclEval self {set a "foo"} +test winDde-3.1 {DDE execute locally} -constraints dde -body { + set \xe1 "" + dde execute TclEval self [list set \xe1 foo] + set \xe1 +} -result foo +test winDde-3.2 {DDE execute -async locally} -constraints dde -body { + set \xe1 "" + dde execute -async TclEval self [list set \xe1 foo] update - set a -} foo -test winDde-3.3 {DDE request locally} {win dde} { - set a "" - dde execute TclEval self {set a "foo"} - dde request TclEval self a -} foo -test winDde-3.4 {DDE eval locally} {win dde} { - set a "" - dde eval self set a "foo" -} foo -test winDde-3.5 {DDE request locally} {win dde} { - set a "" - dde execute TclEval self {set a "foo"} - dde request -binary TclEval self a -} "foo\x00" + set \xe1 +} -result foo +test winDde-3.3 {DDE request locally} -constraints dde -body { + set \xe1 "" + dde execute TclEval self [list set \xe1 foo] + dde request TclEval self \xe1 +} -result foo +test winDde-3.4 {DDE eval locally} -constraints dde -body { + set \xe1 "" + dde eval self set \xe1 foo +} -result foo +test winDde-3.5 {DDE request locally} -constraints dde -body { + set \xe1 "" + dde execute TclEval self [list set \xe1 foo] + dde request -binary TclEval self \xe1 +} -result "foo\x00" +# Set variable a to A with diaeresis (unicode C4) by relying on the fact +# that utf8 is sent (e.g. "c3 84" on the wire) +test winDde-3.6 {DDE request utf8} -constraints dde -body { + set \xe1 "not set" + dde execute TclEval self "set \xe1 \xc4" + scan [set \xe1] %c +} -result 196 +# Set variable a to A with diaeresis (unicode C4) using binary execute +# and compose utf-8 (e.g. "c3 84" ) manualy +test winDde-3.7 {DDE request binary} -constraints dde -body { + set \xe1 "not set" + dde execute -binary TclEval self [list set \xc3\xa1 \xc3\x84\x00] + scan [set \xe1] %c +} -result 196 +test winDde-3.8 {DDE poke locally} -constraints {dde debug} -body { + set \xe1 "" + dde poke TclEval self \xe1 \xc4 + dde request TclEval self \xe1 +} -result \xc4 +test winDde-3.9 {DDE poke -binary locally} -constraints {dde debug} -body { + set \xe1 "" + dde poke -binary TclEval self \xe1 \xc3\x84\x00 + dde request TclEval self \xe1 +} -result \xc4 # ------------------------------------------------------------------------- -test winDde-4.1 {DDE execute remotely} {stdio win dde} { - set a "" - set name child-4.1 +test winDde-4.1 {DDE execute remotely} -constraints {dde stdio} -body { + set \xe1 "" + set name ch\xEDld-4.1 set child [createChildProcess $name] - dde execute TclEval $name {set a "foo"} + dde execute TclEval $name [list set \xe1 foo] dde execute TclEval $name {set done 1} update - set a -} "" -test winDde-4.2 {DDE execute async remotely} {stdio win dde} { - set a "" - set name child-4.2 + set \xe1 +} -result "" +test winDde-4.2 {DDE execute async remotely} -constraints {dde stdio} -body { + set \xe1 "" + set name ch\xEDld-4.2 set child [createChildProcess $name] - dde execute -async TclEval $name {set a "foo"} + dde execute -async TclEval $name [list set \xe1 foo] update dde execute TclEval $name {set done 1} update - set a -} "" -test winDde-4.3 {DDE request remotely} {stdio win dde} { - set a "" - set name chile-4.3 + set \xe1 +} -result "" +test winDde-4.3 {DDE request remotely} -constraints {dde stdio} -body { + set \xe1 "" + set name ch\xEDld-4.3 + set child [createChildProcess $name] + dde execute TclEval $name [list set \xe1 foo] + set \xe1 [dde request TclEval $name \xe1] + dde execute TclEval $name {set done 1} + update + set \xe1 +} -result foo +test winDde-4.4 {DDE eval remotely} -constraints {dde stdio} -body { + set \xe1 "" + set name ch\xEDld-4.4 set child [createChildProcess $name] - dde execute TclEval $name {set a "foo"} - set a [dde request TclEval $name a] + set \xe1 [dde eval $name set \xe1 foo] dde execute TclEval $name {set done 1} update - set a -} foo -test winDde-4.4 {DDE eval remotely} {stdio win dde} { - set a "" - set name child-4.4 + set \xe1 +} -result foo +test winDde-4.5 {DDE poke remotely} -constraints {dde debug stdio} -body { + set \xe1 "" + set name ch\xEDld-4.5 set child [createChildProcess $name] - set a [dde eval $name set a "foo"] + dde poke TclEval $name \xe1 foo + set \xe1 [dde request TclEval $name \xe1] dde execute TclEval $name {set done 1} update - set a -} foo + set \xe1 +} -result foo # ------------------------------------------------------------------------- -test winDde-5.1 {check for bad arguments} -constraints {win dde} -body { +test winDde-5.1 {check for bad arguments} -constraints dde -body { dde execute "" "" "" "" -} -returnCodes error -result {wrong # args: should be "dde execute ?-async? serviceName topicName value"} -test winDde-5.2 {check for bad arguments} -constraints {win dde} -body { - dde execute "" "" "" +} -returnCodes error -result {wrong # args: should be "dde execute ?-async? ?-binary? serviceName topicName value"} +test winDde-5.2 {check for bad arguments} -constraints dde -body { + dde execute -binary "" "" "" } -returnCodes error -result {cannot execute null data} -test winDde-5.3 {check for bad arguments} -constraints {win dde} -body { +test winDde-5.3 {check for bad arguments} -constraints dde -body { dde execute -foo "" "" "" -} -returnCodes error -result {wrong # args: should be "dde execute ?-async? serviceName topicName value"} -test winDde-5.4 {DDE eval bad arguments} -constraints {win dde} -body { +} -returnCodes error -result {wrong # args: should be "dde execute ?-async? ?-binary? serviceName topicName value"} +test winDde-5.4 {DDE eval bad arguments} -constraints dde -body { dde eval "" "foo" } -returnCodes error -result {invalid service name ""} # ------------------------------------------------------------------------- -test winDde-6.1 {DDE servername bad arguments} -constraints {win dde} -body { +test winDde-6.1 {DDE servername bad arguments} -constraints dde -body { dde servername -z -z -z } -returnCodes error -result {bad option "-z": must be -force, -handler, or --} -test winDde-6.2 {DDE servername set name} -constraints {win dde} -body { +test winDde-6.2 {DDE servername set name} -constraints dde -body { dde servername -- winDde-6.2 } -result {winDde-6.2} -test winDde-6.3 {DDE servername set exact name} -constraints {win dde} -body { +test winDde-6.3 {DDE servername set exact name} -constraints dde -body { dde servername -force winDde-6.3 } -result {winDde-6.3} -test winDde-6.4 {DDE servername set exact name} -constraints {win dde} -body { +test winDde-6.4 {DDE servername set exact name} -constraints dde -body { dde servername -force -- winDde-6.4 } -result {winDde-6.4} -test winDde-6.5 {DDE remote servername collision} -constraints {stdio win dde} -setup { - set name child-6.5 +test winDde-6.5 {DDE remote servername collision} -constraints {dde stdio} -setup { + set name ch\xEDld-6.5 set child [createChildProcess $name] } -body { dde servername -- $name } -cleanup { dde execute TclEval $name {set done 1} update -} -result "child-6.5 #2" -test winDde-6.6 {DDE remote servername collision force} -constraints {stdio win dde} -setup { - set name child-6.6 +} -result "ch\xEDld-6.5 #2" +test winDde-6.6 {DDE remote servername collision force} -constraints {dde stdio} -setup { + set name ch\xEDld-6.6 set child [createChildProcess $name] } -body { dde servername -force -- $name } -cleanup { dde execute TclEval $name {set done 1} update -} -result {child-6.6} +} -result "ch\xEDld-6.6" # ------------------------------------------------------------------------- -test winDde-7.1 {Load DDE in slave interpreter } -constraints {win dde} -setup { +test winDde-7.1 {Load DDE in slave interpreter} -constraints dde -setup { interp create slave } -body { slave eval [list load $::ddelib Dde] @@ -250,7 +287,7 @@ test winDde-7.1 {Load DDE in slave interpreter } -constraints {win dde} -setup { } -cleanup { interp delete slave } -result {dde-interp-7.1} -test winDde-7.2 {DDE slave cleanup} -constraints {win dde} -setup { +test winDde-7.2 {DDE slave cleanup} -constraints dde -setup { interp create slave slave eval [list load $::ddelib Dde] slave eval [list dde servername -- dde-interp-7.5] @@ -259,11 +296,11 @@ test winDde-7.2 {DDE slave cleanup} -constraints {win dde} -setup { dde services TclEval {} set s [dde services TclEval {}] set m [list [list TclEval dde-interp-7.5]] - if {[lsearch -exact $s $m] != -1} { + if {$m in $s} { set s } } -result {} -test winDde-7.3 {DDE present in slave interp} -constraints {win dde} -setup { +test winDde-7.3 {DDE present in slave interp} -constraints dde -setup { interp create slave slave eval [list load $::ddelib Dde] slave eval [list dde servername -- dde-interp-7.3] @@ -272,7 +309,7 @@ test winDde-7.3 {DDE present in slave interp} -constraints {win dde} -setup { } -cleanup { interp delete slave } -result {{TclEval dde-interp-7.3}} -test winDde-7.4 {interp name collision with -force} -constraints {win dde} -setup { +test winDde-7.4 {interp name collision with -force} -constraints dde -setup { interp create slave slave eval [list load $::ddelib Dde] slave eval [list dde servername -- dde-interp-7.4] @@ -281,7 +318,7 @@ test winDde-7.4 {interp name collision with -force} -constraints {win dde} -setu } -cleanup { interp delete slave } -result {dde-interp-7.4} -test winDde-7.5 {interp name collision without -force} -constraints {win dde} -setup { +test winDde-7.5 {interp name collision without -force} -constraints dde -setup { interp create slave slave eval [list load $::ddelib Dde] slave eval [list dde servername -- dde-interp-7.5] @@ -293,7 +330,7 @@ test winDde-7.5 {interp name collision without -force} -constraints {win dde} -s # ------------------------------------------------------------------------- -test winDde-8.1 {Safe DDE load} -constraints {win dde} -setup { +test winDde-8.1 {Safe DDE load} -constraints dde -setup { interp create -safe slave slave invokehidden load $::ddelib Dde } -body { @@ -301,20 +338,20 @@ test winDde-8.1 {Safe DDE load} -constraints {win dde} -setup { } -cleanup { interp delete slave } -returnCodes error -result {invalid command name "dde"} -test winDde-8.2 {Safe DDE set servername} -constraints {win dde} -setup { +test winDde-8.2 {Safe DDE set servername} -constraints dde -setup { interp create -safe slave slave invokehidden load $::ddelib Dde } -body { slave invokehidden dde servername slave } -cleanup {interp delete slave} -result {slave} -test winDde-8.3 {Safe DDE check handler required for eval} -constraints {win dde} -setup { +test winDde-8.3 {Safe DDE check handler required for eval} -constraints dde -setup { interp create -safe slave slave invokehidden load $::ddelib Dde slave invokehidden dde servername slave } -body { catch {dde eval slave set a 1} msg } -cleanup {interp delete slave} -result {1} -test winDde-8.4 {Safe DDE check that execute is denied} -constraints {win dde} -setup { +test winDde-8.4 {Safe DDE check that execute is denied} -constraints dde -setup { interp create -safe slave slave invokehidden load $::ddelib Dde slave invokehidden dde servername slave @@ -323,7 +360,7 @@ test winDde-8.4 {Safe DDE check that execute is denied} -constraints {win dde} - dde execute TclEval slave {set a 2} slave eval set a } -cleanup {interp delete slave} -result 1 -test winDde-8.5 {Safe DDE check that request is denied} -constraints {win dde} -setup { +test winDde-8.5 {Safe DDE check that request is denied} -constraints dde -setup { interp create -safe slave slave invokehidden load $::ddelib Dde slave invokehidden dde servername slave @@ -333,14 +370,14 @@ test winDde-8.5 {Safe DDE check that request is denied} -constraints {win dde} - } -cleanup { interp delete slave } -returnCodes error -result {remote server cannot handle this command} -test winDde-8.6 {Safe DDE assign handler procedure} -constraints {win dde} -setup { +test winDde-8.6 {Safe DDE assign handler procedure} -constraints dde -setup { interp create -safe slave slave invokehidden load $::ddelib Dde slave eval {proc DDEACCEPT {cmd} {set ::DDECMD $cmd}} } -body { slave invokehidden dde servername -handler DDEACCEPT slave } -cleanup {interp delete slave} -result slave -test winDde-8.7 {Safe DDE check simple command} -constraints {win dde} -setup { +test winDde-8.7 {Safe DDE check simple command} -constraints dde -setup { interp create -safe slave slave invokehidden load $::ddelib Dde slave eval {proc DDEACCEPT {cmd} {set ::DDECMD $cmd}} @@ -348,7 +385,7 @@ test winDde-8.7 {Safe DDE check simple command} -constraints {win dde} -setup { } -body { dde eval slave set x 1 } -cleanup {interp delete slave} -result {set x 1} -test winDde-8.8 {Safe DDE check non-list command} -constraints {win dde} -setup { +test winDde-8.8 {Safe DDE check non-list command} -constraints dde -setup { interp create -safe slave slave invokehidden load $::ddelib Dde slave eval {proc DDEACCEPT {cmd} {set ::DDECMD $cmd}} @@ -358,16 +395,16 @@ test winDde-8.8 {Safe DDE check non-list command} -constraints {win dde} -setup dde eval slave $s string equal [slave eval set DDECMD] $s } -cleanup {interp delete slave} -result 1 -test winDde-8.9 {Safe DDE check command evaluation} -constraints {win dde} -setup { +test winDde-8.9 {Safe DDE check command evaluation} -constraints dde -setup { interp create -safe slave slave invokehidden load $::ddelib Dde slave eval {proc DDEACCEPT {cmd} {set ::DDECMD [uplevel \#0 $cmd]}} slave invokehidden dde servername -handler DDEACCEPT slave } -body { - dde eval slave set x 1 - slave eval set x + dde eval slave set \xe1 1 + slave eval set \xe1 } -cleanup {interp delete slave} -result 1 -test winDde-8.10 {Safe DDE check command evaluation (2)} -constraints {win dde} -setup { +test winDde-8.10 {Safe DDE check command evaluation (2)} -constraints dde -setup { interp create -safe slave slave invokehidden load $::ddelib Dde slave eval {proc DDEACCEPT {cmd} {set ::DDECMD [uplevel \#0 $cmd]}} @@ -376,7 +413,7 @@ test winDde-8.10 {Safe DDE check command evaluation (2)} -constraints {win dde} dde eval slave [list set x 1] slave eval set x } -cleanup {interp delete slave} -result 1 -test winDde-8.11 {Safe DDE check command evaluation (3)} -constraints {win dde} -setup { +test winDde-8.11 {Safe DDE check command evaluation (3)} -constraints dde -setup { interp create -safe slave slave invokehidden load $::ddelib Dde slave eval {proc DDEACCEPT {cmd} {set ::DDECMD [uplevel \#0 $cmd]}} @@ -388,9 +425,9 @@ test winDde-8.11 {Safe DDE check command evaluation (3)} -constraints {win dde} # ------------------------------------------------------------------------- -test winDde-9.1 {External safe DDE check string passing} -constraints {win dde stdio} -setup { - set name child-9.1 - set child [createChildProcess $name Handler1] +test winDde-9.1 {External safe DDE check string passing} -constraints {dde stdio} -setup { + set name ch\xEDld-9.1 + set child [createChildProcess $name -handler Handler1] file copy -force script1.tcl dde-script.tcl } -body { dde eval $name set x 1 @@ -401,9 +438,9 @@ test winDde-9.1 {External safe DDE check string passing} -constraints {win dde s update file delete -force -- dde-script.tcl } -result {set x 1} -test winDde-9.2 {External safe DDE check command evaluation} -constraints {win dde stdio} -setup { - set name child-9.2 - set child [createChildProcess $name Handler2] +test winDde-9.2 {External safe DDE check command evaluation} -constraints {dde stdio} -setup { + set name ch\xEDld-9.2 + set child [createChildProcess $name -handler Handler2] file copy -force script1.tcl dde-script.tcl } -body { dde eval $name set x 1 @@ -414,9 +451,9 @@ test winDde-9.2 {External safe DDE check command evaluation} -constraints {win d update file delete -force -- dde-script.tcl } -result 1 -test winDde-9.3 {External safe DDE check prefixed arguments} -constraints {win dde stdio} -setup { - set name child-9.3 - set child [createChildProcess $name [list Handler3 ARG]] +test winDde-9.3 {External safe DDE check prefixed arguments} -constraints {dde stdio} -setup { + set name ch\xEDld-9.3 + set child [createChildProcess $name -handler [list Handler3 ARG]] file copy -force script1.tcl dde-script.tcl } -body { dde eval $name set x 1 @@ -427,6 +464,19 @@ test winDde-9.3 {External safe DDE check prefixed arguments} -constraints {win d update file delete -force -- dde-script.tcl } -result {ARG {set x 1}} +test winDde-9.4 {External safe DDE check null data passing} -constraints {dde stdio} -setup { + set name ch\xEDld-9.4 + set child [createChildProcess $name -handler Handler1] + file copy -force script1.tcl dde-script.tcl +} -body { + dde execute TclEval $name "" + gets $child line + set line +} -cleanup { + dde execute TclEval $name stop + update + file delete -force -- dde-script.tcl +} -result {null data} # ------------------------------------------------------------------------- diff --git a/win/Makefile.in b/win/Makefile.in index 6d1ce95..7fc415d 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -498,7 +498,7 @@ tclWinReg.${OBJEXT} : tclWinReg.c $(CC) -c $(CC_SWITCHES) -DUNICODE -D_UNICODE -DUSE_TCL_STUBS @DEPARG@ $(CC_OBJNAME) tclWinDde.${OBJEXT} : tclWinDde.c - $(CC) -c $(CC_SWITCHES) -DUSE_TCL_STUBS @DEPARG@ $(CC_OBJNAME) + $(CC) -c $(CC_SWITCHES) -DUNICODE -D_UNICODE -DUSE_TCL_STUBS @DEPARG@ $(CC_OBJNAME) # TIP #59, embedding of configuration information into the binary library. # @@ -709,13 +709,13 @@ install-private-headers: libraries test: binaries $(TCLTEST) TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \ ./$(TCLTEST) "$(ROOT_DIR_NATIVE)/tests/all.tcl" $(TESTFLAGS) \ - -load "package ifneeded dde 1.3.3 [list load [file normalize ${DDE_DLL_FILE}] dde]; \ + -load "package ifneeded dde 1.4.1 [list load [file normalize ${DDE_DLL_FILE}] dde]; \ package ifneeded registry 1.3.3 [list load [file normalize ${REG_DLL_FILE}] registry]" | ./$(CAT32) # Useful target to launch a built tcltest with the proper path,... runtest: binaries $(TCLTEST) @TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \ - ./$(TCLTEST) $(TESTFLAGS) -load "package ifneeded dde 1.3.3 [list load [file normalize ${DDE_DLL_FILE}] dde]; \ + ./$(TCLTEST) $(TESTFLAGS) -load "package ifneeded dde 1.4.1 [list load [file normalize ${DDE_DLL_FILE}] dde]; \ package ifneeded registry 1.3.3 [list load [file normalize ${REG_DLL_FILE}] registry]" $(SCRIPT) # This target can be used to run tclsh from the build directory via diff --git a/win/configure b/win/configure index 3fe89bf..3a77f00 100755 --- a/win/configure +++ b/win/configure @@ -1314,14 +1314,14 @@ TCL_MINOR_VERSION=5 TCL_PATCH_LEVEL=".19" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION -TCL_DDE_VERSION=1.3 +TCL_DDE_VERSION=1.4 TCL_DDE_MAJOR_VERSION=1 -TCL_DDE_MINOR_VERSION=3 +TCL_DDE_MINOR_VERSION=4 DDEVER=$TCL_DDE_MAJOR_VERSION$TCL_DDE_MINOR_VERSION -TCL_REG_VERSION=1.2 +TCL_REG_VERSION=1.3 TCL_REG_MAJOR_VERSION=1 -TCL_REG_MINOR_VERSION=2 +TCL_REG_MINOR_VERSION=3 REGVER=$TCL_REG_MAJOR_VERSION$TCL_REG_MINOR_VERSION #------------------------------------------------------------------------ diff --git a/win/configure.in b/win/configure.in index fa75e5b..12c81ed 100644 --- a/win/configure.in +++ b/win/configure.in @@ -17,9 +17,9 @@ TCL_MINOR_VERSION=5 TCL_PATCH_LEVEL=".19" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION -TCL_DDE_VERSION=1.3 +TCL_DDE_VERSION=1.4 TCL_DDE_MAJOR_VERSION=1 -TCL_DDE_MINOR_VERSION=3 +TCL_DDE_MINOR_VERSION=4 DDEVER=$TCL_DDE_MAJOR_VERSION$TCL_DDE_MINOR_VERSION TCL_REG_VERSION=1.3 diff --git a/win/makefile.bc b/win/makefile.bc index 20d89bc..577c865 100644 --- a/win/makefile.bc +++ b/win/makefile.bc @@ -127,8 +127,8 @@ STUBPREFIX = $(NAMEPREFIX)stub DOTVERSION = 8.5 VERSION = 85 -DDEVERSION = 13 -DDEDOTVERSION = 1.3 +DDEVERSION = 14 +DDEDOTVERSION = 1.4 REGVERSION = 13 REGDOTVERSION = 1.3 diff --git a/win/makefile.vc b/win/makefile.vc index c330fcd..62a4d67 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -538,13 +538,13 @@ test-core: setup $(TCLTEST) dlls $(CAT32) set TCL_LIBRARY=$(ROOT:\=/)/library !if "$(OS)" == "Windows_NT" || "$(MSVCDIR)" == "IDE" $(DEBUGGER) $(TCLTEST) "$(ROOT:\=/)/tests/all.tcl" $(TESTFLAGS) -loadfile << - package ifneeded dde 1.3.3 [list load "$(TCLDDELIB:\=/)" dde] + package ifneeded dde 1.4.1 [list load "$(TCLDDELIB:\=/)" dde] package ifneeded registry 1.3.3 [list load "$(TCLREGLIB:\=/)" registry] << !else @echo Please wait while the tests are collected... $(TCLTEST) "$(ROOT:\=/)/tests/all.tcl" $(TESTFLAGS) -loadfile << > tests.log - package ifneeded dde 1.3.3 "$(TCLDDELIB:\=/)" dde] + package ifneeded dde 1.4.1 "$(TCLDDELIB:\=/)" dde] package ifneeded registry 1.3.3 "$(TCLREGLIB:\=/)" registry] << type tests.log | more diff --git a/win/tclWinDde.c b/win/tclWinDde.c index eef5caa..38f1d88 100644 --- a/win/tclWinDde.c +++ b/win/tclWinDde.c @@ -10,20 +10,20 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ +#undef STATIC_BUILD +#ifndef USE_TCL_STUBS +# define USE_TCL_STUBS +#endif #include "tclInt.h" -#include "tclPort.h" #include #include +#include -/* - * TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the Dde_Init - * declaration is in the source file itself, which is only accessed when we - * are building a library. DO NOT MOVE BEFORE ANY #include LINES. ONLY USE - * EXTERN TO INDICATE EXPORTED FUNCTIONS FROM NOW ON. - */ - -#undef TCL_STORAGE_CLASS -#define TCL_STORAGE_CLASS DLLEXPORT +#if !defined(NDEBUG) + /* test POKE server Implemented for debug mode only */ +# undef CBF_FAIL_POKES +# define CBF_FAIL_POKES 0 +#endif /* * The following structure is used to keep track of the interpreters @@ -34,7 +34,7 @@ typedef struct RegisteredInterp { struct RegisteredInterp *nextPtr; /* The next interp this application knows * about. */ - char *name; /* Interpreter's name (malloc-ed). */ + TCHAR *name; /* Interpreter's name (malloc-ed). */ Tcl_Obj *handlerPtr; /* The server handler command */ Tcl_Interp *interp; /* The interpreter attached to this name. */ } RegisteredInterp; @@ -51,7 +51,7 @@ typedef struct Conversation { Tcl_Obj *returnPackagePtr; /* The result package for this conversation. */ } Conversation; -typedef struct DdeEnumServices { +typedef struct { Tcl_Interp *interp; int result; ATOM service; @@ -59,7 +59,7 @@ typedef struct DdeEnumServices { HWND hwnd; } DdeEnumServices; -typedef struct ThreadSpecificData { +typedef struct { Conversation *currentConversations; /* A list of conversations currently being * processed. */ @@ -79,9 +79,10 @@ static DWORD ddeInstance; /* The application instance handle given to us * by DdeInitialize. */ static int ddeIsServer = 0; +#define TCL_DDE_VERSION "1.4.1" #define TCL_DDE_PACKAGE_NAME "dde" -#define TCL_DDE_SERVICE_NAME "TclEval" -#define TCL_DDE_EXECUTE_RESULT "$TCLEVAL$EXECUTE$RESULT" +#define TCL_DDE_SERVICE_NAME TEXT("TclEval") +#define TCL_DDE_EXECUTE_RESULT TEXT("$TCLEVAL$EXECUTE$RESULT") #define DDE_FLAG_ASYNC 1 #define DDE_FLAG_BINARY 2 @@ -95,12 +96,12 @@ TCL_DECLARE_MUTEX(ddeMutex) static LRESULT CALLBACK DdeClientWindowProc(HWND hwnd, UINT uMsg, WPARAM wParam, LPARAM lParam); -static int DdeCreateClient(struct DdeEnumServices *es); +static int DdeCreateClient(DdeEnumServices *es); static BOOL CALLBACK DdeEnumWindowsCallback(HWND hwndTarget, LPARAM lParam); static void DdeExitProc(ClientData clientData); static int DdeGetServicesList(Tcl_Interp *interp, - const char *serviceName, const char *topicName); + const TCHAR *serviceName, const TCHAR *topicName); static HDDEDATA CALLBACK DdeServerProc(UINT uType, UINT uFmt, HCONV hConv, HSZ ddeTopic, HSZ ddeItem, HDDEDATA hData, DWORD dwData1, DWORD dwData2); @@ -110,14 +111,15 @@ static void DeleteProc(ClientData clientData); static Tcl_Obj * ExecuteRemoteObject(RegisteredInterp *riPtr, Tcl_Obj *ddeObjectPtr); static int MakeDdeConnection(Tcl_Interp *interp, - const char *name, HCONV *ddeConvPtr); + const TCHAR *name, HCONV *ddeConvPtr); static void SetDdeError(Tcl_Interp *interp); static int DdeObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -EXTERN int Dde_Init(Tcl_Interp *interp); -EXTERN int Dde_SafeInit(Tcl_Interp *interp); + +DLLEXPORT int Dde_Init(Tcl_Interp *interp); +DLLEXPORT int Dde_SafeInit(Tcl_Interp *interp); /* *---------------------------------------------------------------------- @@ -145,7 +147,7 @@ Dde_Init( Tcl_CreateObjCommand(interp, "dde", DdeObjCmd, NULL, NULL); Tcl_CreateExitHandler(DdeExitProc, NULL); - return Tcl_PkgProvide(interp, TCL_DDE_PACKAGE_NAME, "1.3.3"); + return Tcl_PkgProvide(interp, TCL_DDE_PACKAGE_NAME, TCL_DDE_VERSION); } /* @@ -229,7 +231,7 @@ Initialize(void) ddeIsServer = 1; Tcl_CreateExitHandler(DdeExitProc, NULL); ddeServiceGlobal = DdeCreateStringHandle(ddeInstance, - TCL_DDE_SERVICE_NAME, 0); + TCL_DDE_SERVICE_NAME, CP_WINUNICODE); DdeNameService(ddeInstance, ddeServiceGlobal, 0L, DNS_REGISTER); } else { ddeIsServer = 0; @@ -263,10 +265,10 @@ Initialize(void) *---------------------------------------------------------------------- */ -static const char * +static const TCHAR * DdeSetServerName( Tcl_Interp *interp, - const char *name, /* The name that will be used to refer to the + const TCHAR *name, /* The name that will be used to refer to the * interpreter in later "send" commands. Must * be globally unique. */ int flags, /* DDE_FLAG_FORCE or 0 */ @@ -276,7 +278,7 @@ DdeSetServerName( int suffix, offset; RegisteredInterp *riPtr, *prevPtr; Tcl_DString dString; - const char *actualName; + const TCHAR *actualName; Tcl_Obj *srvListPtr = NULL, **srvPtrPtr = NULL; int n, srvCount = 0, lastSuffix, r = TCL_OK; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -314,7 +316,7 @@ DdeSetServerName( * current interp, but it doesn't have a name. */ - return ""; + return TEXT(""); } /* @@ -335,7 +337,9 @@ DdeSetServerName( &srvPtrPtr); } if (r != TCL_OK) { - OutputDebugString(Tcl_GetStringResult(interp)); + Tcl_WinUtfToTChar(Tcl_GetStringResult(interp), -1, &dString); + OutputDebugString((TCHAR *) Tcl_DStringValue(&dString)); + Tcl_DStringFree(&dString); return NULL; } @@ -352,13 +356,14 @@ DdeSetServerName( lastSuffix = suffix; if (suffix > 1) { if (suffix == 2) { - Tcl_DStringAppend(&dString, name, -1); - Tcl_DStringAppend(&dString, " #", 2); + Tcl_DStringAppend(&dString, (char *)name, _tcslen(name) * sizeof(TCHAR)); + Tcl_DStringAppend(&dString, (char *)TEXT(" #"), 2 * sizeof(TCHAR)); offset = Tcl_DStringLength(&dString); - Tcl_DStringSetLength(&dString, offset + TCL_INTEGER_SPACE); - actualName = Tcl_DStringValue(&dString); + Tcl_DStringSetLength(&dString, offset + sizeof(TCHAR) * TCL_INTEGER_SPACE); + actualName = (TCHAR *) Tcl_DStringValue(&dString); } - sprintf(Tcl_DStringValue(&dString) + offset, "%d", suffix); + _sntprintf((TCHAR *) (Tcl_DStringValue(&dString) + offset), + TCL_INTEGER_SPACE, TEXT("%d"), suffix); } /* @@ -367,39 +372,41 @@ DdeSetServerName( for (n = 0; n < srvCount; ++n) { Tcl_Obj* namePtr; + Tcl_DString ds; Tcl_ListObjIndex(interp, srvPtrPtr[n], 1, &namePtr); - if (strcmp(actualName, Tcl_GetString(namePtr)) == 0) { + Tcl_WinUtfToTChar(Tcl_GetString(namePtr), -1, &ds); + if (_tcscmp(actualName, (TCHAR *)Tcl_DStringValue(&ds)) == 0) { suffix++; + Tcl_DStringFree(&ds); break; } + Tcl_DStringFree(&ds); } } - Tcl_DStringSetLength(&dString, - offset + (int)strlen(Tcl_DStringValue(&dString)+offset)); } /* * We have found a unique name. Now add it to the registry. */ - riPtr = (RegisteredInterp *) ckalloc(sizeof(RegisteredInterp)); + riPtr = (RegisteredInterp *) Tcl_Alloc(sizeof(RegisteredInterp)); riPtr->interp = interp; - riPtr->name = ckalloc((unsigned int) strlen(actualName) + 1); + riPtr->name = (TCHAR *) Tcl_Alloc((_tcslen(actualName) + 1) * sizeof(TCHAR)); riPtr->nextPtr = tsdPtr->interpListPtr; riPtr->handlerPtr = handlerPtr; if (riPtr->handlerPtr != NULL) { Tcl_IncrRefCount(riPtr->handlerPtr); } tsdPtr->interpListPtr = riPtr; - strcpy(riPtr->name, actualName); + _tcscpy(riPtr->name, actualName); if (Tcl_IsSafe(interp)) { Tcl_ExposeCommand(interp, "dde", "dde"); } Tcl_CreateObjCommand(interp, "dde", DdeObjCmd, - (ClientData) riPtr, DeleteProc); + riPtr, DeleteProc); if (Tcl_IsSafe(interp)) { Tcl_HideCommand(interp, "dde", "dde"); } @@ -486,7 +493,7 @@ DeleteProc( prevPtr->nextPtr = searchPtr->nextPtr; } } - ckfree(riPtr->name); + Tcl_Free((char *) riPtr->name); if (riPtr->handlerPtr) { Tcl_DecrRefCount(riPtr->handlerPtr); } @@ -524,10 +531,11 @@ ExecuteRemoteObject( Tcl_Obj *returnPackagePtr; int result = TCL_OK; - if (riPtr->handlerPtr == NULL && Tcl_IsSafe(riPtr->interp)) { + if ((riPtr->handlerPtr == NULL) && Tcl_IsSafe(riPtr->interp)) { Tcl_SetObjResult(riPtr->interp, Tcl_NewStringObj("permission denied: " "a handler procedure must be defined for use in a safe " "interp", -1)); + Tcl_SetErrorCode(riPtr->interp, "TCL", "DDE", "SECURITY_CHECK", NULL); result = TCL_ERROR; } @@ -605,9 +613,9 @@ DdeServerProc( /* Transaction-dependent data. */ { Tcl_DString dString; - int len; + size_t len; DWORD dlen; - char *utilString; + TCHAR *utilString; Tcl_Obj *ddeObjectPtr; HDDEDATA ddeReturn = NULL; RegisteredInterp *riPtr; @@ -621,16 +629,16 @@ DdeServerProc( * sure we have a valid topic. */ - len = DdeQueryString(ddeInstance, ddeTopic, NULL, 0, 0); + len = DdeQueryString(ddeInstance, ddeTopic, NULL, 0, CP_WINUNICODE); Tcl_DStringInit(&dString); - Tcl_DStringSetLength(&dString, len); - utilString = Tcl_DStringValue(&dString); + Tcl_DStringSetLength(&dString, (len + 1) * sizeof(TCHAR) - 1); + utilString = (TCHAR *) Tcl_DStringValue(&dString); DdeQueryString(ddeInstance, ddeTopic, utilString, (DWORD) len + 1, - CP_WINANSI); + CP_WINUNICODE); for (riPtr = tsdPtr->interpListPtr; riPtr != NULL; riPtr = riPtr->nextPtr) { - if (stricmp(utilString, riPtr->name) == 0) { + if (_tcsicmp(utilString, riPtr->name) == 0) { Tcl_DStringFree(&dString); return (HDDEDATA) TRUE; } @@ -646,16 +654,16 @@ DdeServerProc( * result to return in an XTYP_REQUEST. */ - len = DdeQueryString(ddeInstance, ddeTopic, NULL, 0, 0); + len = DdeQueryString(ddeInstance, ddeTopic, NULL, 0, CP_WINUNICODE); Tcl_DStringInit(&dString); - Tcl_DStringSetLength(&dString, len); - utilString = Tcl_DStringValue(&dString); + Tcl_DStringSetLength(&dString, (len + 1) * sizeof(TCHAR) - 1); + utilString = (TCHAR *) Tcl_DStringValue(&dString); DdeQueryString(ddeInstance, ddeTopic, utilString, (DWORD) len + 1, - CP_WINANSI); + CP_WINUNICODE); for (riPtr = tsdPtr->interpListPtr; riPtr != NULL; riPtr = riPtr->nextPtr) { - if (stricmp(riPtr->name, utilString) == 0) { - convPtr = (Conversation *) ckalloc(sizeof(Conversation)); + if (_tcsicmp(riPtr->name, utilString) == 0) { + convPtr = (Conversation *) Tcl_Alloc(sizeof(Conversation)); convPtr->nextPtr = tsdPtr->currentConversations; convPtr->returnPackagePtr = NULL; convPtr->hConv = hConv; @@ -685,7 +693,7 @@ DdeServerProc( if (convPtr->returnPackagePtr != NULL) { Tcl_DecrRefCount(convPtr->returnPackagePtr); } - ckfree((char *) convPtr); + Tcl_Free((char *) convPtr); break; } } @@ -711,22 +719,24 @@ DdeServerProc( } if (convPtr != NULL) { + Tcl_DString dsBuf; char *returnString; - len = DdeQueryString(ddeInstance, ddeItem, NULL, 0, CP_WINANSI); + len = DdeQueryString(ddeInstance, ddeItem, NULL, 0, CP_WINUNICODE); Tcl_DStringInit(&dString); - Tcl_DStringSetLength(&dString, len); - utilString = Tcl_DStringValue(&dString); + Tcl_DStringInit(&dsBuf); + Tcl_DStringSetLength(&dString, (len + 1) * sizeof(TCHAR) - 1); + utilString = (TCHAR *) Tcl_DStringValue(&dString); DdeQueryString(ddeInstance, ddeItem, utilString, (DWORD) len + 1, - CP_WINANSI); - if (stricmp(utilString, TCL_DDE_EXECUTE_RESULT) == 0) { - if (uFmt == CF_TEXT) { - returnString = - Tcl_GetStringFromObj(convPtr->returnPackagePtr, &len); - } else { - returnString = (char *) - Tcl_GetUnicodeFromObj(convPtr->returnPackagePtr, &len); - len = 2 * len + 1; + CP_WINUNICODE); + if (_tcsicmp(utilString, TCL_DDE_EXECUTE_RESULT) == 0) { + returnString = + Tcl_GetString(convPtr->returnPackagePtr); + len = convPtr->returnPackagePtr->length; + if (uFmt != CF_TEXT) { + Tcl_WinUtfToTChar(returnString, len, &dsBuf); + returnString = Tcl_DStringValue(&dsBuf); + len = Tcl_DStringLength(&dsBuf) + sizeof(TCHAR) - 1; } ddeReturn = DdeCreateDataHandle(ddeInstance, (BYTE *)returnString, (DWORD) len+1, 0, ddeItem, uFmt, 0); @@ -734,17 +744,20 @@ DdeServerProc( if (Tcl_IsSafe(convPtr->riPtr->interp)) { ddeReturn = NULL; } else { - Tcl_Obj *variableObjPtr = Tcl_GetVar2Ex( - convPtr->riPtr->interp, utilString, NULL, + Tcl_DString ds; + Tcl_Obj *variableObjPtr; + + Tcl_WinTCharToUtf(utilString, -1, &ds); + variableObjPtr = Tcl_GetVar2Ex( + convPtr->riPtr->interp, Tcl_DStringValue(&ds), NULL, TCL_GLOBAL_ONLY); if (variableObjPtr != NULL) { - if (uFmt == CF_TEXT) { - returnString = Tcl_GetStringFromObj( - variableObjPtr, &len); - } else { - returnString = (char *) Tcl_GetUnicodeFromObj( - variableObjPtr, &len); - len = 2 * len + 1; + returnString = Tcl_GetString(variableObjPtr); + len = variableObjPtr->length; + if (uFmt != CF_TEXT) { + Tcl_WinUtfToTChar(returnString, len, &dsBuf); + returnString = Tcl_DStringValue(&dsBuf); + len = Tcl_DStringLength(&dsBuf) + sizeof(TCHAR) - 1; } ddeReturn = DdeCreateDataHandle(ddeInstance, (BYTE *)returnString, (DWORD) len+1, 0, ddeItem, @@ -752,12 +765,65 @@ DdeServerProc( } else { ddeReturn = NULL; } + Tcl_DStringFree(&ds); } } + Tcl_DStringFree(&dsBuf); + Tcl_DStringFree(&dString); + } + return ddeReturn; + +#if !CBF_FAIL_POKES + case XTYP_POKE: + /* + * This is a poke for a Tcl variable, only implemented in + * debug/UNICODE mode. + */ + ddeReturn = DDE_FNOTPROCESSED; + + if ((uFmt != CF_TEXT) && (uFmt != CF_UNICODETEXT)) { + return ddeReturn; + } + + for (convPtr = tsdPtr->currentConversations; (convPtr != NULL) + && (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) { + /* + * Empty loop body. + */ + } + + if (convPtr && !Tcl_IsSafe(convPtr->riPtr->interp)) { + Tcl_DString ds, ds2; + Tcl_Obj *variableObjPtr; + DWORD len2; + + Tcl_DStringInit(&dString); + Tcl_DStringInit(&ds2); + len = DdeQueryString(ddeInstance, ddeItem, NULL, 0, CP_WINUNICODE); + Tcl_DStringSetLength(&dString, (len + 1) * sizeof(TCHAR) - 1); + utilString = (TCHAR *) Tcl_DStringValue(&dString); + DdeQueryString(ddeInstance, ddeItem, utilString, (DWORD) len + 1, + CP_WINUNICODE); + Tcl_WinTCharToUtf(utilString, -1, &ds); + utilString = (TCHAR *) DdeAccessData(hData, &len2); + len = len2; + if (uFmt != CF_TEXT) { + Tcl_WinTCharToUtf(utilString, -1, &ds2); + utilString = (TCHAR *) Tcl_DStringValue(&ds2); + } + variableObjPtr = Tcl_NewStringObj((char *)utilString, -1); + + Tcl_SetVar2Ex(convPtr->riPtr->interp, Tcl_DStringValue(&ds), NULL, + variableObjPtr, TCL_GLOBAL_ONLY); + + Tcl_DStringFree(&ds2); + Tcl_DStringFree(&ds); Tcl_DStringFree(&dString); + ddeReturn = (HDDEDATA) DDE_FACK; } return ddeReturn; +#endif case XTYP_EXECUTE: { /* * Execute this script. The results will be saved into a list object @@ -765,7 +831,7 @@ DdeServerProc( */ Tcl_Obj *returnPackagePtr; - Tcl_UniChar *uniStr; + char *string; for (convPtr = tsdPtr->currentConversations; (convPtr != NULL) && (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) { @@ -778,21 +844,25 @@ DdeServerProc( return (HDDEDATA) DDE_FNOTPROCESSED; } - utilString = (char *) DdeAccessData(hData, &dlen); - uniStr = (Tcl_UniChar *) utilString; + utilString = (TCHAR *) DdeAccessData(hData, &dlen); + string = (char *) utilString; if (!dlen) { /* Empty binary array. */ ddeObjectPtr = Tcl_NewObj(); - } else if ((dlen & 1) || uniStr[(dlen>>1)-1]) { + } else if ((dlen & 1) || utilString[(dlen>>1)-1]) { /* Cannot be unicode, so assume utf-8 */ - if (!utilString[dlen-1]) { + if (!string[dlen-1]) { dlen--; } - ddeObjectPtr = Tcl_NewStringObj(utilString, dlen); + ddeObjectPtr = Tcl_NewStringObj(string, dlen); } else { /* unicode */ - dlen >>= 1; - ddeObjectPtr = Tcl_NewUnicodeObj(uniStr, dlen - 1); + Tcl_DString dsBuf; + + Tcl_WinTCharToUtf(utilString, dlen - sizeof(TCHAR), &dsBuf); + ddeObjectPtr = Tcl_NewStringObj(Tcl_DStringValue(&dsBuf), + Tcl_DStringLength(&dsBuf)); + Tcl_DStringFree(&dsBuf); } Tcl_IncrRefCount(ddeObjectPtr); DdeUnaccessData(hData); @@ -845,9 +915,9 @@ DdeServerProc( for (i = 0, riPtr = tsdPtr->interpListPtr; i < numItems; i++, riPtr = riPtr->nextPtr) { returnPtr[i].hszSvc = DdeCreateStringHandle(ddeInstance, - TCL_DDE_SERVICE_NAME, CP_WINANSI); + TCL_DDE_SERVICE_NAME, CP_WINUNICODE); returnPtr[i].hszTopic = DdeCreateStringHandle(ddeInstance, - riPtr->name, CP_WINANSI); + riPtr->name, CP_WINUNICODE); } returnPtr[i].hszSvc = NULL; returnPtr[i].hszTopic = NULL; @@ -905,14 +975,14 @@ DdeExitProc( static int MakeDdeConnection( Tcl_Interp *interp, /* Used to report errors. */ - const char *name, /* The connection to use. */ + const TCHAR *name, /* The connection to use. */ HCONV *ddeConvPtr) { HSZ ddeTopic, ddeService; HCONV ddeConv; - ddeService = DdeCreateStringHandle(ddeInstance, TCL_DDE_SERVICE_NAME, 0); - ddeTopic = DdeCreateStringHandle(ddeInstance, name, 0); + ddeService = DdeCreateStringHandle(ddeInstance, TCL_DDE_SERVICE_NAME, CP_WINUNICODE); + ddeTopic = DdeCreateStringHandle(ddeInstance, name, CP_WINUNICODE); ddeConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL); DdeFreeStringHandle(ddeInstance, ddeService); @@ -920,8 +990,13 @@ MakeDdeConnection( if (ddeConv == (HCONV) NULL) { if (interp != NULL) { - Tcl_AppendResult(interp, "no registered server named \"", - name, "\"", NULL); + Tcl_DString dString; + + Tcl_WinTCharToUtf(name, -1, &dString); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "no registered server named \"%s\"", Tcl_DStringValue(&dString))); + Tcl_DStringFree(&dString); + Tcl_SetErrorCode(interp, "TCL", "DDE", "NO_SERVER", NULL); } return TCL_ERROR; } @@ -952,17 +1027,17 @@ MakeDdeConnection( static int DdeCreateClient( - struct DdeEnumServices *es) + DdeEnumServices *es) { WNDCLASSEX wc; - static const char *szDdeClientClassName = "TclEval client class"; - static const char *szDdeClientWindowName = "TclEval client window"; + static const TCHAR *szDdeClientClassName = TEXT("TclEval client class"); + static const TCHAR *szDdeClientWindowName = TEXT("TclEval client window"); memset(&wc, 0, sizeof(wc)); wc.cbSize = sizeof(wc); wc.lpfnWndProc = DdeClientWindowProc; wc.lpszClassName = szDdeClientClassName; - wc.cbWndExtra = sizeof(struct DdeEnumServices *); + wc.cbWndExtra = sizeof(DdeEnumServices *); /* * Register and create the callback window. @@ -984,8 +1059,8 @@ DdeClientWindowProc( switch (uMsg) { case WM_CREATE: { LPCREATESTRUCT lpcs = (LPCREATESTRUCT) lParam; - struct DdeEnumServices *es = - (struct DdeEnumServices *) lpcs->lpCreateParams; + DdeEnumServices *es = + (DdeEnumServices *) lpcs->lpCreateParams; #ifdef _WIN64 SetWindowLongPtr(hwnd, GWLP_USERDATA, (LONG_PTR) es); @@ -1010,24 +1085,29 @@ DdeServicesOnAck( HWND hwndRemote = (HWND)wParam; ATOM service = (ATOM)LOWORD(lParam); ATOM topic = (ATOM)HIWORD(lParam); - struct DdeEnumServices *es; - char sz[255]; + DdeEnumServices *es; + TCHAR sz[255]; + Tcl_DString dString; #ifdef _WIN64 - es = (struct DdeEnumServices *) GetWindowLongPtr(hwnd, GWLP_USERDATA); + es = (DdeEnumServices *) GetWindowLongPtr(hwnd, GWLP_USERDATA); #else - es = (struct DdeEnumServices *) GetWindowLong(hwnd, GWL_USERDATA); + es = (DdeEnumServices *) GetWindowLong(hwnd, GWL_USERDATA); #endif - if ((es->service == (ATOM)0 || es->service == service) - && (es->topic == (ATOM)0 || es->topic == topic)) { + if (((es->service == (ATOM)0) || (es->service == service)) + && ((es->topic == (ATOM)0) || (es->topic == topic))) { Tcl_Obj *matchPtr = Tcl_NewListObj(0, NULL); Tcl_Obj *resultPtr = Tcl_GetObjResult(es->interp); GlobalGetAtomName(service, sz, 255); - Tcl_ListObjAppendElement(NULL, matchPtr, Tcl_NewStringObj(sz, -1)); + Tcl_WinTCharToUtf(sz, -1, &dString); + Tcl_ListObjAppendElement(NULL, matchPtr, Tcl_NewStringObj(Tcl_DStringValue(&dString), -1)); + Tcl_DStringFree(&dString); GlobalGetAtomName(topic, sz, 255); - Tcl_ListObjAppendElement(NULL, matchPtr, Tcl_NewStringObj(sz, -1)); + Tcl_WinTCharToUtf(sz, -1, &dString); + Tcl_ListObjAppendElement(NULL, matchPtr, Tcl_NewStringObj(Tcl_DStringValue(&dString), -1)); + Tcl_DStringFree(&dString); /* * Adding the hwnd as a third list element provides a unique @@ -1063,7 +1143,7 @@ DdeEnumWindowsCallback( LPARAM lParam) { DWORD_PTR dwResult = 0; - struct DdeEnumServices *es = (struct DdeEnumServices *) lParam; + DdeEnumServices *es = (DdeEnumServices *) lParam; SendMessageTimeout(hwndTarget, WM_DDE_INITIATE, (WPARAM)es->hwnd, MAKELONG(es->service, es->topic), SMTO_ABORTIFHUNG, 1000, @@ -1074,10 +1154,10 @@ DdeEnumWindowsCallback( static int DdeGetServicesList( Tcl_Interp *interp, - const char *serviceName, - const char *topicName) + const TCHAR *serviceName, + const TCHAR *topicName) { - struct DdeEnumServices es; + DdeEnumServices es; es.interp = interp; es.result = TCL_OK; @@ -1122,25 +1202,30 @@ static void SetDdeError( Tcl_Interp *interp) /* The interp to put the message in. */ { - const char *errorMessage; + const char *errorMessage, *errorCode; switch (DdeGetLastError(ddeInstance)) { case DMLERR_DATAACKTIMEOUT: case DMLERR_EXECACKTIMEOUT: case DMLERR_POKEACKTIMEOUT: errorMessage = "remote interpreter did not respond"; + errorCode = "TIMEOUT"; break; case DMLERR_BUSY: errorMessage = "remote server is busy"; + errorCode = "BUSY"; break; case DMLERR_NOTPROCESSED: errorMessage = "remote server cannot handle this command"; + errorCode = "NOCANDO"; break; default: errorMessage = "dde command failed"; + errorCode = "FAILED"; } Tcl_SetObjResult(interp, Tcl_NewStringObj(errorMessage, -1)); + Tcl_SetErrorCode(interp, "TCL", "DDE", errorCode, NULL); } /* @@ -1167,34 +1252,43 @@ DdeObjCmd( int objc, /* Number of arguments */ Tcl_Obj *const *objv) /* The arguments */ { - static const char *ddeCommands[] = { + static const char *const ddeCommands[] = { "servername", "execute", "poke", "request", "services", "eval", (char *) NULL}; enum DdeSubcommands { DDE_SERVERNAME, DDE_EXECUTE, DDE_POKE, DDE_REQUEST, DDE_SERVICES, DDE_EVAL }; - static const char *ddeSrvOptions[] = { + static const char *const ddeSrvOptions[] = { "-force", "-handler", "--", NULL }; enum DdeSrvOptions { DDE_SERVERNAME_EXACT, DDE_SERVERNAME_HANDLER, DDE_SERVERNAME_LAST, }; - static const char *ddeExecOptions[] = { + static const char *const ddeExecOptions[] = { + "-async", "-binary", NULL + }; + enum DdeExecOptions { + DDE_EXEC_ASYNC, DDE_EXEC_BINARY + }; + static const char *const ddeEvalOptions[] = { "-async", NULL }; - static const char *ddeReqOptions[] = { + static const char *const ddeReqOptions[] = { "-binary", NULL }; - int index, i, length, argIndex; + int index, i, argIndex; + int length; int flags = 0, result = TCL_OK, firstArg = 0; HSZ ddeService = NULL, ddeTopic = NULL, ddeItem = NULL, ddeCookie = NULL; HDDEDATA ddeData = NULL, ddeItemData = NULL, ddeReturn; HCONV hConv = NULL; - const char *serviceName = NULL, *topicName = NULL, *string; + const TCHAR *serviceName = NULL, *topicName = NULL; + const char *string; DWORD ddeResult; Tcl_Obj *objPtr, *handlerPtr = NULL; + Tcl_DString serviceBuf, topicBuf, itemBuf; /* * Initialize DDE server/client @@ -1210,6 +1304,9 @@ DdeObjCmd( return TCL_ERROR; } + Tcl_DStringInit(&serviceBuf); + Tcl_DStringInit(&topicBuf); + Tcl_DStringInit(&itemBuf); switch ((enum DdeSubcommands) index) { case DDE_SERVERNAME: for (i = 2; i < objc; i++) { @@ -1259,38 +1356,53 @@ DdeObjCmd( if (objc == 5) { firstArg = 2; break; - } else if (objc == 6) { - if (Tcl_GetIndexFromObj(NULL, objv[2], ddeExecOptions, "option", 0, - &argIndex) == TCL_OK) { - flags |= DDE_FLAG_ASYNC; - firstArg = 3; - break; + } else if ((objc >= 6) && (objc <= 7)) { + firstArg = objc - 3; + for (i = 2; i < firstArg; i++) { + if (Tcl_GetIndexFromObj(interp, objv[i], ddeExecOptions, + "option", 0, &argIndex) != TCL_OK) { + goto wrongDdeExecuteArgs; + } + if (argIndex == DDE_EXEC_ASYNC) { + flags |= DDE_FLAG_ASYNC; + } else { + flags |= DDE_FLAG_BINARY; + } } + break; } /* otherwise... */ + wrongDdeExecuteArgs: Tcl_WrongNumArgs(interp, 2, objv, - "?-async? serviceName topicName value"); + "?-async? ?-binary? serviceName topicName value"); return TCL_ERROR; case DDE_POKE: - if (objc != 6) { - Tcl_WrongNumArgs(interp, 2, objv, - "serviceName topicName item value"); - return TCL_ERROR; + if (objc == 6) { + firstArg = 2; + break; + } else if ((objc == 7) && (Tcl_GetIndexFromObj(NULL, objv[2], + ddeReqOptions, "option", 0, &argIndex) == TCL_OK)) { + flags |= DDE_FLAG_BINARY; + firstArg = 3; + break; } - firstArg = 2; - break; + + /* + * Otherwise... + */ + + Tcl_WrongNumArgs(interp, 2, objv, + "?-binary? serviceName topicName item value"); + return TCL_ERROR; case DDE_REQUEST: if (objc == 5) { firstArg = 2; break; - } else if (objc == 6) { - int dummy; - if (Tcl_GetIndexFromObj(NULL, objv[2], ddeReqOptions, "option", 0, - &dummy) == TCL_OK) { - flags |= DDE_FLAG_BINARY; - firstArg = 3; - break; - } + } else if ((objc == 6) && (Tcl_GetIndexFromObj(NULL, objv[2], + ddeReqOptions, "option", 0, &argIndex) == TCL_OK)) { + flags |= DDE_FLAG_BINARY; + firstArg = 3; + break; } /* @@ -1314,7 +1426,7 @@ DdeObjCmd( return TCL_ERROR; } else { firstArg = 2; - if (Tcl_GetIndexFromObj(NULL, objv[2], ddeExecOptions, "option", + if (Tcl_GetIndexFromObj(NULL, objv[2], ddeEvalOptions, "option", 0, &argIndex) == TCL_OK) { if (objc < 5) { goto wrongDdeEvalArgs; @@ -1329,7 +1441,12 @@ DdeObjCmd( Initialize(); if (firstArg != 1) { - serviceName = Tcl_GetStringFromObj(objv[firstArg], &length); + const char *src = Tcl_GetString(objv[firstArg]); + + length = objv[firstArg]->length; + Tcl_WinUtfToTChar(src, length, &serviceBuf); + serviceName = (TCHAR *) Tcl_DStringValue(&serviceBuf); + length = Tcl_DStringLength(&serviceBuf) / sizeof(TCHAR); } else { length = 0; } @@ -1338,16 +1455,20 @@ DdeObjCmd( serviceName = NULL; } else if ((index != DDE_SERVERNAME) && (index != DDE_EVAL)) { ddeService = DdeCreateStringHandle(ddeInstance, (void *) serviceName, - CP_WINANSI); + CP_WINUNICODE); } if ((index != DDE_SERVERNAME) && (index != DDE_EVAL)) { - topicName = Tcl_GetStringFromObj(objv[firstArg + 1], &length); + const char *src = Tcl_GetString(objv[firstArg + 1]); + + length = objv[firstArg + 1]->length; + topicName = Tcl_WinUtfToTChar(src, length, &topicBuf); + length = Tcl_DStringLength(&topicBuf) / sizeof(TCHAR); if (length == 0) { topicName = NULL; } else { ddeTopic = DdeCreateStringHandle(ddeInstance, (void *) topicName, - CP_WINANSI); + CP_WINUNICODE); } } @@ -1356,7 +1477,12 @@ DdeObjCmd( serviceName = DdeSetServerName(interp, serviceName, flags, handlerPtr); if (serviceName != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj(serviceName, -1)); + Tcl_DString dsBuf; + + Tcl_WinTCharToUtf(serviceName, -1, &dsBuf); + Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_DStringValue(&dsBuf), + Tcl_DStringLength(&dsBuf))); + Tcl_DStringFree(&dsBuf); } else { Tcl_ResetResult(interp); } @@ -1364,12 +1490,28 @@ DdeObjCmd( case DDE_EXECUTE: { int dataLength; - BYTE *dataString = (BYTE *) Tcl_GetStringFromObj( - objv[firstArg + 2], &dataLength); + const void *dataString; + Tcl_DString dsBuf; + + Tcl_DStringInit(&dsBuf); + if (flags & DDE_FLAG_BINARY) { + dataString = + Tcl_GetByteArrayFromObj(objv[firstArg + 2], &dataLength); + } else { + const char *src; + + src = Tcl_GetString(objv[firstArg + 2]); + dataLength = objv[firstArg + 2]->length; + dataString = (const TCHAR *) + Tcl_WinUtfToTChar(src, dataLength, &dsBuf); + dataLength = Tcl_DStringLength(&dsBuf) + sizeof(TCHAR); + } - if (dataLength == 0) { + if (dataLength + 1 < 2) { Tcl_SetObjResult(interp, Tcl_NewStringObj("cannot execute null data", -1)); + Tcl_DStringFree(&dsBuf); + Tcl_SetErrorCode(interp, "TCL", "DDE", "NULL", NULL); result = TCL_ERROR; break; } @@ -1378,21 +1520,22 @@ DdeObjCmd( DdeFreeStringHandle(ddeInstance, ddeTopic); if (hConv == NULL) { + Tcl_DStringFree(&dsBuf); SetDdeError(interp); result = TCL_ERROR; break; } - ddeData = DdeCreateDataHandle(ddeInstance, dataString, - (DWORD) dataLength+1, 0, 0, CF_TEXT, 0); + ddeData = DdeCreateDataHandle(ddeInstance, (BYTE *) dataString, + (DWORD) dataLength, 0, 0, (flags & DDE_FLAG_BINARY) ? CF_TEXT : CF_UNICODETEXT, 0); if (ddeData != NULL) { if (flags & DDE_FLAG_ASYNC) { DdeClientTransaction((LPBYTE) ddeData, 0xFFFFFFFF, hConv, 0, - CF_TEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult); + (flags & DDE_FLAG_BINARY) ? CF_TEXT : CF_UNICODETEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult); DdeAbandonTransaction(ddeInstance, hConv, ddeResult); } else { ddeReturn = DdeClientTransaction((LPBYTE) ddeData, 0xFFFFFFFF, - hConv, 0, CF_TEXT, XTYP_EXECUTE, 30000, NULL); + hConv, 0, (flags & DDE_FLAG_BINARY) ? CF_TEXT : CF_UNICODETEXT, XTYP_EXECUTE, 30000, NULL); if (ddeReturn == 0) { SetDdeError(interp); result = TCL_ERROR; @@ -1403,15 +1546,22 @@ DdeObjCmd( SetDdeError(interp); result = TCL_ERROR; } + Tcl_DStringFree(&dsBuf); break; } case DDE_REQUEST: { - const char *itemString = Tcl_GetStringFromObj(objv[firstArg + 2], - &length); + const TCHAR *itemString; + const char *src; + + src = Tcl_GetString(objv[firstArg + 2]); + length = objv[firstArg + 2]->length; + itemString = Tcl_WinUtfToTChar(src, length, &itemBuf); + length = Tcl_DStringLength(&itemBuf) / sizeof(TCHAR); if (length == 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj("cannot request value of null data", -1)); + Tcl_SetErrorCode(interp, "TCL", "DDE", "NULL", NULL); result = TCL_ERROR; goto cleanup; } @@ -1424,27 +1574,33 @@ DdeObjCmd( result = TCL_ERROR; } else { Tcl_Obj *returnObjPtr; - ddeItem = DdeCreateStringHandle(ddeInstance, (void *)itemString, - CP_WINANSI); + ddeItem = DdeCreateStringHandle(ddeInstance, (void *) itemString, + CP_WINUNICODE); if (ddeItem != NULL) { ddeData = DdeClientTransaction(NULL, 0, hConv, ddeItem, - CF_TEXT, XTYP_REQUEST, 5000, NULL); + (flags & DDE_FLAG_BINARY) ? CF_TEXT : CF_UNICODETEXT, XTYP_REQUEST, 5000, NULL); if (ddeData == NULL) { SetDdeError(interp); result = TCL_ERROR; } else { DWORD tmp; - const char *dataString = (const char *) DdeAccessData(ddeData, &tmp); + TCHAR *dataString = (TCHAR *) DdeAccessData(ddeData, &tmp); if (flags & DDE_FLAG_BINARY) { returnObjPtr = - Tcl_NewByteArrayObj((BYTE *) dataString, (int) tmp); + Tcl_NewByteArrayObj((BYTE *) dataString, tmp); } else { - if (tmp && !dataString[tmp-1]) { - --tmp; + Tcl_DString dsBuf; + + if ((tmp >= sizeof(TCHAR)) + && !dataString[tmp / sizeof(TCHAR) - 1]) { + tmp -= sizeof(TCHAR); } - returnObjPtr = Tcl_NewStringObj(dataString, - (int) tmp); + Tcl_WinTCharToUtf(dataString, tmp, &dsBuf); + returnObjPtr = + Tcl_NewStringObj(Tcl_DStringValue(&dsBuf), + Tcl_DStringLength(&dsBuf)); + Tcl_DStringFree(&dsBuf); } DdeUnaccessData(ddeData); DdeFreeDataHandle(ddeData); @@ -1455,22 +1611,37 @@ DdeObjCmd( result = TCL_ERROR; } } - break; } case DDE_POKE: { - const char *itemString = Tcl_GetStringFromObj(objv[firstArg + 2], - &length); + Tcl_DString dsBuf; + const TCHAR *itemString; BYTE *dataString; + const char *src; + src = Tcl_GetString(objv[firstArg + 2]); + length = objv[firstArg + 2]->length; + itemString = Tcl_WinUtfToTChar(src, length, &itemBuf); + length = Tcl_DStringLength(&itemBuf) / sizeof(TCHAR); if (length == 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj("cannot have a null item", -1)); + Tcl_SetErrorCode(interp, "TCL", "DDE", "NULL", NULL); result = TCL_ERROR; goto cleanup; } - dataString = (BYTE *) Tcl_GetStringFromObj(objv[firstArg + 3], - &length); + Tcl_DStringInit(&dsBuf); + if (flags & DDE_FLAG_BINARY) { + dataString = (BYTE *) + Tcl_GetByteArrayFromObj(objv[firstArg + 3], &length); + } else { + const char *data = + Tcl_GetString(objv[firstArg + 3]); + length = objv[firstArg + 3]->length; + dataString = (BYTE *) + Tcl_WinUtfToTChar(data, length, &dsBuf); + length = Tcl_DStringLength(&dsBuf) + sizeof(TCHAR); + } hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL); DdeFreeStringHandle(ddeInstance, ddeService); @@ -1481,10 +1652,10 @@ DdeObjCmd( result = TCL_ERROR; } else { ddeItem = DdeCreateStringHandle(ddeInstance, (void *) itemString, - CP_WINANSI); + CP_WINUNICODE); if (ddeItem != NULL) { - ddeData = DdeClientTransaction(dataString, (DWORD) length+1, - hConv, ddeItem, CF_TEXT, XTYP_POKE, 5000, NULL); + ddeData = DdeClientTransaction(dataString, (DWORD) length, + hConv, ddeItem, (flags & DDE_FLAG_BINARY) ? CF_TEXT : CF_UNICODETEXT, XTYP_POKE, 5000, NULL); if (ddeData == NULL) { SetDdeError(interp); result = TCL_ERROR; @@ -1494,6 +1665,7 @@ DdeObjCmd( result = TCL_ERROR; } } + Tcl_DStringFree(&dsBuf); break; } @@ -1508,6 +1680,7 @@ DdeObjCmd( if (serviceName == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj("invalid service name \"\"", -1)); + Tcl_SetErrorCode(interp, "TCL", "DDE", "NO_SERVER", NULL); result = TCL_ERROR; goto cleanup; } @@ -1526,7 +1699,7 @@ DdeObjCmd( for (riPtr = tsdPtr->interpListPtr; riPtr != NULL; riPtr = riPtr->nextPtr) { - if (stricmp(serviceName, riPtr->name) == 0) { + if (_tcsicmp(serviceName, riPtr->name) == 0) { break; } } @@ -1539,9 +1712,9 @@ DdeObjCmd( * server. */ - Tcl_Preserve((ClientData) riPtr); + Tcl_Preserve(riPtr); sendInterp = riPtr->interp; - Tcl_Preserve((ClientData) sendInterp); + Tcl_Preserve(sendInterp); /* * Don't exchange objects between interps. The target interp would @@ -1551,10 +1724,12 @@ DdeObjCmd( * referring to deallocated objects. */ - if (Tcl_IsSafe(riPtr->interp) && riPtr->handlerPtr == NULL) { - Tcl_SetResult(riPtr->interp, "permission denied: " - "a handler procedure must be defined for use in " - "a safe interp", TCL_STATIC); + if (Tcl_IsSafe(riPtr->interp) && (riPtr->handlerPtr == NULL)) { + Tcl_SetObjResult(riPtr->interp, Tcl_NewStringObj( + "permission denied: a handler procedure must be" + " defined for use in a safe interp", -1)); + Tcl_SetErrorCode(interp, "TCL", "DDE", "SECURITY_CHECK", + NULL); result = TCL_ERROR; } @@ -1594,8 +1769,7 @@ DdeObjCmd( objPtr = Tcl_GetVar2Ex(sendInterp, "errorInfo", NULL, TCL_GLOBAL_ONLY); if (objPtr) { - string = Tcl_GetStringFromObj(objPtr, &length); - Tcl_AddObjErrorInfo(interp, string, length); + Tcl_AppendObjToErrorInfo(interp, objPtr); } objPtr = Tcl_GetVar2Ex(sendInterp, "errorCode", NULL, @@ -1606,9 +1780,11 @@ DdeObjCmd( } Tcl_SetObjResult(interp, Tcl_GetObjResult(sendInterp)); } - Tcl_Release((ClientData) riPtr); - Tcl_Release((ClientData) sendInterp); + Tcl_Release(riPtr); + Tcl_Release(sendInterp); } else { + Tcl_DString dsBuf; + /* * This is a non-local request. Send the script to the server and * poll it for a result. @@ -1617,31 +1793,36 @@ DdeObjCmd( if (MakeDdeConnection(interp, serviceName, &hConv) != TCL_OK) { invalidServerResponse: Tcl_SetObjResult(interp, - Tcl_NewStringObj("invalid data returned from server", - -1)); + Tcl_NewStringObj("invalid data returned from server", -1)); + Tcl_SetErrorCode(interp, "TCL", "DDE", "BAD_RESPONSE", NULL); result = TCL_ERROR; goto cleanup; } objPtr = Tcl_ConcatObj(objc, objv); - string = Tcl_GetStringFromObj(objPtr, &length); - ddeItemData = DdeCreateDataHandle(ddeInstance, - (BYTE *) string, (DWORD) length+1, 0, 0, CF_TEXT, 0); + string = Tcl_GetString(objPtr); + length = objPtr->length; + Tcl_WinUtfToTChar(string, length, &dsBuf); + string = Tcl_DStringValue(&dsBuf); + length = Tcl_DStringLength(&dsBuf) + sizeof(TCHAR); + ddeItemData = DdeCreateDataHandle(ddeInstance, (BYTE *) string, + (DWORD) length, 0, 0, CF_UNICODETEXT, 0); + Tcl_DStringFree(&dsBuf); if (flags & DDE_FLAG_ASYNC) { ddeData = DdeClientTransaction((LPBYTE) ddeItemData, 0xFFFFFFFF, hConv, 0, - CF_TEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult); + CF_UNICODETEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult); DdeAbandonTransaction(ddeInstance, hConv, ddeResult); } else { ddeData = DdeClientTransaction((LPBYTE) ddeItemData, 0xFFFFFFFF, hConv, 0, - CF_TEXT, XTYP_EXECUTE, 30000, NULL); + CF_UNICODETEXT, XTYP_EXECUTE, 30000, NULL); if (ddeData != 0) { ddeCookie = DdeCreateStringHandle(ddeInstance, - TCL_DDE_EXECUTE_RESULT, CP_WINANSI); + TCL_DDE_EXECUTE_RESULT, CP_WINUNICODE); ddeData = DdeClientTransaction(NULL, 0, hConv, ddeCookie, - CF_TEXT, XTYP_REQUEST, 30000, NULL); + CF_UNICODETEXT, XTYP_REQUEST, 30000, NULL); } } @@ -1650,10 +1831,12 @@ DdeObjCmd( if (ddeData == 0) { SetDdeError(interp); result = TCL_ERROR; + goto cleanup; } if (!(flags & DDE_FLAG_ASYNC)) { Tcl_Obj *resultPtr; + TCHAR *ddeDataString; /* * The return handle has a two or four element list in it. The @@ -1664,12 +1847,17 @@ DdeObjCmd( * variable "errorInfo". */ - resultPtr = Tcl_NewObj(); length = DdeGetData(ddeData, NULL, 0, 0); - Tcl_SetObjLength(resultPtr, length); - string = Tcl_GetString(resultPtr); - DdeGetData(ddeData, (BYTE *) string, (DWORD) length, 0); - Tcl_SetObjLength(resultPtr, (int) strlen(string)); + ddeDataString = (TCHAR *) Tcl_Alloc(length); + DdeGetData(ddeData, (BYTE *) ddeDataString, (DWORD) length, 0); + if (length > sizeof(TCHAR)) { + length -= sizeof(TCHAR); + } + Tcl_WinTCharToUtf(ddeDataString, length, &dsBuf); + resultPtr = Tcl_NewStringObj(Tcl_DStringValue(&dsBuf), + Tcl_DStringLength(&dsBuf)); + Tcl_DStringFree(&dsBuf); + Tcl_Free((char *) ddeDataString); if (Tcl_ListObjIndex(NULL, resultPtr, 0, &objPtr) != TCL_OK) { Tcl_DecrRefCount(resultPtr); @@ -1687,9 +1875,7 @@ DdeObjCmd( Tcl_DecrRefCount(resultPtr); goto invalidServerResponse; } - length = -1; - string = Tcl_GetStringFromObj(objPtr, &length); - Tcl_AddObjErrorInfo(interp, string, length); + Tcl_AppendObjToErrorInfo(interp, objPtr); Tcl_ListObjIndex(NULL, resultPtr, 2, &objPtr); Tcl_SetObjErrorCode(interp, objPtr); @@ -1721,6 +1907,9 @@ DdeObjCmd( if (hConv != NULL) { DdeDisconnect(hConv); } + Tcl_DStringFree(&itemBuf); + Tcl_DStringFree(&topicBuf); + Tcl_DStringFree(&serviceBuf); return result; } diff --git a/win/tclWinReg.c b/win/tclWinReg.c index f3d7a07..0d2cd94 100644 --- a/win/tclWinReg.c +++ b/win/tclWinReg.c @@ -492,7 +492,6 @@ DeleteValue( { HKEY key; char *valueName; - size_t length; DWORD result; Tcl_DString ds; @@ -506,8 +505,7 @@ DeleteValue( } valueName = Tcl_GetString(valueNameObj); - length = valueNameObj->length; - Tcl_WinUtfToTChar(valueName, length, &ds); + Tcl_WinUtfToTChar(valueName, valueNameObj->length, &ds); result = RegDeleteValue(key, (const TCHAR *)Tcl_DStringValue(&ds)); Tcl_DStringFree(&ds); if (result != ERROR_SUCCESS) { @@ -647,7 +645,6 @@ GetType( Tcl_DString ds; const char *valueName; const TCHAR *nativeValue; - size_t length; /* * Attempt to open the key for reading. @@ -663,8 +660,7 @@ GetType( */ valueName = Tcl_GetString(valueNameObj); - length = valueNameObj->length; - nativeValue = Tcl_WinUtfToTChar(valueName, length, &ds); + nativeValue = Tcl_WinUtfToTChar(valueName, valueNameObj->length, &ds); result = RegQueryValueEx(key, nativeValue, NULL, &type, NULL, NULL); Tcl_DStringFree(&ds); @@ -720,7 +716,6 @@ GetValue( const TCHAR *nativeValue; DWORD result, length, type; Tcl_DString data, buf; - size_t nameLen; /* * Attempt to open the key for reading. @@ -746,8 +741,7 @@ GetValue( length = TCL_DSTRING_STATIC_SIZE/sizeof(TCHAR) - 1; valueName = Tcl_GetString(valueNameObj); - nameLen = valueNameObj->length; - nativeValue = Tcl_WinUtfToTChar(valueName, nameLen, &buf); + nativeValue = Tcl_WinUtfToTChar(valueName, valueNameObj->length, &buf); result = RegQueryValueEx(key, nativeValue, NULL, &type, (BYTE *) Tcl_DStringValue(&data), &length); @@ -936,13 +930,11 @@ OpenKey( HKEY *keyPtr) /* Returned HKEY. */ { char *keyName, *buffer, *hostName; - size_t length; HKEY rootKey; DWORD result; keyName = Tcl_GetString(keyNameObj); - length = keyNameObj->length; - buffer = Tcl_Alloc(length + 1); + buffer = Tcl_Alloc(keyNameObj->length + 1); strcpy(buffer, keyName); result = ParseKeyName(interp, buffer, &hostName, &rootKey, &keyName); @@ -1244,7 +1236,6 @@ SetValue( REGSAM mode) /* Mode flags to pass. */ { int type; - size_t length; DWORD result; HKEY key; const char *valueName; @@ -1265,8 +1256,7 @@ SetValue( } valueName = Tcl_GetString(valueNameObj); - length = valueNameObj->length; - valueName = (char *) Tcl_WinUtfToTChar(valueName, length, &nameBuf); + valueName = (char *) Tcl_WinUtfToTChar(valueName, valueNameObj->length, &nameBuf); if (type == REG_DWORD || type == REG_DWORD_BIG_ENDIAN) { int value; @@ -1301,8 +1291,7 @@ SetValue( for (i = 0; i < objc; i++) { const char *bytes = Tcl_GetString(objv[i]); - length = objv[i]->length; - Tcl_DStringAppend(&data, bytes, length); + Tcl_DStringAppend(&data, bytes, objv[i]->length); /* * Add a null character to separate this value from the next. @@ -1322,18 +1311,16 @@ SetValue( Tcl_DString buf; const char *data = Tcl_GetString(dataObj); - length = dataObj->length; - data = (char *) Tcl_WinUtfToTChar(data, length, &buf); + data = (char *) Tcl_WinUtfToTChar(data, dataObj->length, &buf); /* * Include the null in the length, padding if needed for WCHAR. */ Tcl_DStringSetLength(&buf, Tcl_DStringLength(&buf)+1); - length = Tcl_DStringLength(&buf) + 1; result = RegSetValueEx(key, (TCHAR *) valueName, 0, - (DWORD) type, (BYTE *) data, (DWORD) length); + (DWORD) type, (BYTE *) data, (DWORD) Tcl_DStringLength(&buf) + 1); Tcl_DStringFree(&buf); } else { BYTE *data; @@ -1404,8 +1391,7 @@ BroadcastValue( } str = Tcl_GetString(objv[0]); - len = objv[0]->length; - wstr = (WCHAR *) Tcl_WinUtfToTChar(str, len, &ds); + wstr = (WCHAR *) Tcl_WinUtfToTChar(str, objv[0]->length, &ds); if (Tcl_DStringLength(&ds) == 0) { wstr = NULL; } -- cgit v0.12 From d7a697aa505f57e3135239964c90863202c4f815 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 27 Oct 2018 08:03:56 +0000 Subject: Missed some version bumps in previous commit --- win/makefile.vc | 2 +- win/rules.vc | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/win/makefile.vc b/win/makefile.vc index 62a4d67..95a34d7 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -182,7 +182,7 @@ STUBPREFIX = $(PROJECT)stub DOTVERSION = $(TCL_MAJOR_VERSION).$(TCL_MINOR_VERSION) VERSION = $(TCL_MAJOR_VERSION)$(TCL_MINOR_VERSION) -DDEDOTVERSION = 1.3 +DDEDOTVERSION = 1.4 DDEVERSION = $(DDEDOTVERSION:.=) REGDOTVERSION = 1.3 diff --git a/win/rules.vc b/win/rules.vc index 0ae0e8e..33ebfe2 100644 --- a/win/rules.vc +++ b/win/rules.vc @@ -591,7 +591,7 @@ TCLSTUBLIB = "$(_TCLDIR)\lib\tclstub$(TCL_VERSION).lib" TCLIMPLIB = "$(_TCLDIR)\lib\tcl$(TCL_VERSION)$(SUFX).lib" TCL_LIBRARY = $(_TCLDIR)\lib TCLREGLIB = "$(_TCLDIR)\lib\tclreg13$(SUFX:t=).lib" -TCLDDELIB = "$(_TCLDIR)\lib\tcldde13$(SUFX:t=).lib" +TCLDDELIB = "$(_TCLDIR)\lib\tcldde14$(SUFX:t=).lib" COFFBASE = \must\have\tcl\sources\to\build\this\target TCLTOOLSDIR = \must\have\tcl\sources\to\build\this\target TCL_INCLUDES = -I"$(_TCLDIR)\include" @@ -604,7 +604,7 @@ TCLSTUBLIB = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tclstub$(TCL_VERSION).lib" TCLIMPLIB = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tcl$(TCL_VERSION)$(SUFX).lib" TCL_LIBRARY = $(_TCLDIR)\library TCLREGLIB = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tclreg13$(SUFX:t=).lib" -TCLDDELIB = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tcldde13$(SUFX:t=).lib" +TCLDDELIB = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tcldde14$(SUFX:t=).lib" COFFBASE = "$(_TCLDIR)\win\coffbase.txt" TCLTOOLSDIR = $(_TCLDIR)\tools TCL_INCLUDES = -I"$(_TCLDIR)\generic" -I"$(_TCLDIR)\win" -- cgit v0.12 From fef802ea7a250bb158b599340431c49d115184c6 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 27 Oct 2018 08:06:42 +0000 Subject: Update to latest tzdata (backported from 8.6) --- library/tzdata/Africa/Ceuta | 1 + library/tzdata/America/Santiago | 324 ++++++++++++++++++++-------------------- library/tzdata/Asia/Macau | 68 ++++++--- library/tzdata/Asia/Manila | 18 +-- library/tzdata/Asia/Pyongyang | 2 +- library/tzdata/Asia/Shanghai | 43 +++--- library/tzdata/Asia/Tokyo | 8 +- library/tzdata/Europe/Volgograd | 1 + library/tzdata/Pacific/Easter | 324 ++++++++++++++++++++-------------------- library/tzdata/Pacific/Fiji | 24 +-- 10 files changed, 427 insertions(+), 386 deletions(-) diff --git a/library/tzdata/Africa/Ceuta b/library/tzdata/Africa/Ceuta index 057ca22..18af8c1 100644 --- a/library/tzdata/Africa/Ceuta +++ b/library/tzdata/Africa/Ceuta @@ -15,6 +15,7 @@ set TZData(:Africa/Ceuta) { {-1316390400 3600 1 WEST} {-1301270400 0 0 WET} {-1293840000 0 0 WET} + {-94694400 0 0 WET} {-81432000 3600 1 WEST} {-71110800 0 0 WET} {141264000 3600 1 WEST} diff --git a/library/tzdata/America/Santiago b/library/tzdata/America/Santiago index 67d5b5c..55212b9 100644 --- a/library/tzdata/America/Santiago +++ b/library/tzdata/America/Santiago @@ -124,166 +124,166 @@ set TZData(:America/Santiago) { {1502596800 -10800 1 -04} {1526180400 -14400 0 -04} {1534046400 -10800 1 -04} - {1557630000 -14400 0 -04} - {1565496000 -10800 1 -04} - {1589079600 -14400 0 -04} - {1596945600 -10800 1 -04} - {1620529200 -14400 0 -04} - {1629000000 -10800 1 -04} - {1652583600 -14400 0 -04} - {1660449600 -10800 1 -04} - {1684033200 -14400 0 -04} - {1691899200 -10800 1 -04} - {1715482800 -14400 0 -04} - {1723348800 -10800 1 -04} - {1746932400 -14400 0 -04} - {1754798400 -10800 1 -04} - {1778382000 -14400 0 -04} - {1786248000 -10800 1 -04} - {1809831600 -14400 0 -04} - {1818302400 -10800 1 -04} - {1841886000 -14400 0 -04} - {1849752000 -10800 1 -04} - {1873335600 -14400 0 -04} - {1881201600 -10800 1 -04} - {1904785200 -14400 0 -04} - {1912651200 -10800 1 -04} - {1936234800 -14400 0 -04} - {1944100800 -10800 1 -04} - {1967684400 -14400 0 -04} - {1976155200 -10800 1 -04} - {1999738800 -14400 0 -04} - {2007604800 -10800 1 -04} - {2031188400 -14400 0 -04} - {2039054400 -10800 1 -04} - {2062638000 -14400 0 -04} - {2070504000 -10800 1 -04} - {2094087600 -14400 0 -04} - {2101953600 -10800 1 -04} - {2125537200 -14400 0 -04} - {2133403200 -10800 1 -04} - {2156986800 -14400 0 -04} - {2165457600 -10800 1 -04} - {2189041200 -14400 0 -04} - {2196907200 -10800 1 -04} - {2220490800 -14400 0 -04} - {2228356800 -10800 1 -04} - {2251940400 -14400 0 -04} - {2259806400 -10800 1 -04} - {2283390000 -14400 0 -04} - {2291256000 -10800 1 -04} - {2314839600 -14400 0 -04} - {2322705600 -10800 1 -04} - {2346894000 -14400 0 -04} - {2354760000 -10800 1 -04} - {2378343600 -14400 0 -04} - {2386209600 -10800 1 -04} - {2409793200 -14400 0 -04} - {2417659200 -10800 1 -04} - {2441242800 -14400 0 -04} - {2449108800 -10800 1 -04} - {2472692400 -14400 0 -04} - {2480558400 -10800 1 -04} - {2504142000 -14400 0 -04} - {2512612800 -10800 1 -04} - {2536196400 -14400 0 -04} - {2544062400 -10800 1 -04} - {2567646000 -14400 0 -04} - {2575512000 -10800 1 -04} - {2599095600 -14400 0 -04} - {2606961600 -10800 1 -04} - {2630545200 -14400 0 -04} - {2638411200 -10800 1 -04} - {2661994800 -14400 0 -04} - {2669860800 -10800 1 -04} - {2693444400 -14400 0 -04} - {2701915200 -10800 1 -04} - {2725498800 -14400 0 -04} - {2733364800 -10800 1 -04} - {2756948400 -14400 0 -04} - {2764814400 -10800 1 -04} - {2788398000 -14400 0 -04} - {2796264000 -10800 1 -04} - {2819847600 -14400 0 -04} - {2827713600 -10800 1 -04} - {2851297200 -14400 0 -04} - {2859768000 -10800 1 -04} - {2883351600 -14400 0 -04} - {2891217600 -10800 1 -04} - {2914801200 -14400 0 -04} - {2922667200 -10800 1 -04} - {2946250800 -14400 0 -04} - {2954116800 -10800 1 -04} - {2977700400 -14400 0 -04} - {2985566400 -10800 1 -04} - {3009150000 -14400 0 -04} - {3017016000 -10800 1 -04} - {3040599600 -14400 0 -04} - {3049070400 -10800 1 -04} - {3072654000 -14400 0 -04} - {3080520000 -10800 1 -04} - {3104103600 -14400 0 -04} - {3111969600 -10800 1 -04} - {3135553200 -14400 0 -04} - {3143419200 -10800 1 -04} - {3167002800 -14400 0 -04} - {3174868800 -10800 1 -04} - {3198452400 -14400 0 -04} - {3206318400 -10800 1 -04} - {3230506800 -14400 0 -04} - {3238372800 -10800 1 -04} - {3261956400 -14400 0 -04} - {3269822400 -10800 1 -04} - {3293406000 -14400 0 -04} - {3301272000 -10800 1 -04} - {3324855600 -14400 0 -04} - {3332721600 -10800 1 -04} - {3356305200 -14400 0 -04} - {3364171200 -10800 1 -04} - {3387754800 -14400 0 -04} - {3396225600 -10800 1 -04} - {3419809200 -14400 0 -04} - {3427675200 -10800 1 -04} - {3451258800 -14400 0 -04} - {3459124800 -10800 1 -04} - {3482708400 -14400 0 -04} - {3490574400 -10800 1 -04} - {3514158000 -14400 0 -04} - {3522024000 -10800 1 -04} - {3545607600 -14400 0 -04} - {3553473600 -10800 1 -04} - {3577057200 -14400 0 -04} - {3585528000 -10800 1 -04} - {3609111600 -14400 0 -04} - {3616977600 -10800 1 -04} - {3640561200 -14400 0 -04} - {3648427200 -10800 1 -04} - {3672010800 -14400 0 -04} - {3679876800 -10800 1 -04} - {3703460400 -14400 0 -04} - {3711326400 -10800 1 -04} - {3734910000 -14400 0 -04} - {3743380800 -10800 1 -04} - {3766964400 -14400 0 -04} - {3774830400 -10800 1 -04} - {3798414000 -14400 0 -04} - {3806280000 -10800 1 -04} - {3829863600 -14400 0 -04} - {3837729600 -10800 1 -04} - {3861313200 -14400 0 -04} - {3869179200 -10800 1 -04} - {3892762800 -14400 0 -04} - {3900628800 -10800 1 -04} - {3924212400 -14400 0 -04} - {3932683200 -10800 1 -04} - {3956266800 -14400 0 -04} - {3964132800 -10800 1 -04} - {3987716400 -14400 0 -04} - {3995582400 -10800 1 -04} - {4019166000 -14400 0 -04} - {4027032000 -10800 1 -04} - {4050615600 -14400 0 -04} - {4058481600 -10800 1 -04} - {4082065200 -14400 0 -04} - {4089931200 -10800 1 -04} + {1554606000 -14400 0 -04} + {1567915200 -10800 1 -04} + {1586055600 -14400 0 -04} + {1599364800 -10800 1 -04} + {1617505200 -14400 0 -04} + {1630814400 -10800 1 -04} + {1648954800 -14400 0 -04} + {1662264000 -10800 1 -04} + {1680404400 -14400 0 -04} + {1693713600 -10800 1 -04} + {1712458800 -14400 0 -04} + {1725768000 -10800 1 -04} + {1743908400 -14400 0 -04} + {1757217600 -10800 1 -04} + {1775358000 -14400 0 -04} + {1788667200 -10800 1 -04} + {1806807600 -14400 0 -04} + {1820116800 -10800 1 -04} + {1838257200 -14400 0 -04} + {1851566400 -10800 1 -04} + {1870311600 -14400 0 -04} + {1883016000 -10800 1 -04} + {1901761200 -14400 0 -04} + {1915070400 -10800 1 -04} + {1933210800 -14400 0 -04} + {1946520000 -10800 1 -04} + {1964660400 -14400 0 -04} + {1977969600 -10800 1 -04} + {1996110000 -14400 0 -04} + {2009419200 -10800 1 -04} + {2027559600 -14400 0 -04} + {2040868800 -10800 1 -04} + {2059614000 -14400 0 -04} + {2072318400 -10800 1 -04} + {2091063600 -14400 0 -04} + {2104372800 -10800 1 -04} + {2122513200 -14400 0 -04} + {2135822400 -10800 1 -04} + {2153962800 -14400 0 -04} + {2167272000 -10800 1 -04} + {2185412400 -14400 0 -04} + {2198721600 -10800 1 -04} + {2217466800 -14400 0 -04} + {2230171200 -10800 1 -04} + {2248916400 -14400 0 -04} + {2262225600 -10800 1 -04} + {2280366000 -14400 0 -04} + {2293675200 -10800 1 -04} + {2311815600 -14400 0 -04} + {2325124800 -10800 1 -04} + {2343265200 -14400 0 -04} + {2356574400 -10800 1 -04} + {2374714800 -14400 0 -04} + {2388024000 -10800 1 -04} + {2406769200 -14400 0 -04} + {2419473600 -10800 1 -04} + {2438218800 -14400 0 -04} + {2451528000 -10800 1 -04} + {2469668400 -14400 0 -04} + {2482977600 -10800 1 -04} + {2501118000 -14400 0 -04} + {2514427200 -10800 1 -04} + {2532567600 -14400 0 -04} + {2545876800 -10800 1 -04} + {2564017200 -14400 0 -04} + {2577326400 -10800 1 -04} + {2596071600 -14400 0 -04} + {2609380800 -10800 1 -04} + {2627521200 -14400 0 -04} + {2640830400 -10800 1 -04} + {2658970800 -14400 0 -04} + {2672280000 -10800 1 -04} + {2690420400 -14400 0 -04} + {2703729600 -10800 1 -04} + {2721870000 -14400 0 -04} + {2735179200 -10800 1 -04} + {2753924400 -14400 0 -04} + {2766628800 -10800 1 -04} + {2785374000 -14400 0 -04} + {2798683200 -10800 1 -04} + {2816823600 -14400 0 -04} + {2830132800 -10800 1 -04} + {2848273200 -14400 0 -04} + {2861582400 -10800 1 -04} + {2879722800 -14400 0 -04} + {2893032000 -10800 1 -04} + {2911172400 -14400 0 -04} + {2924481600 -10800 1 -04} + {2943226800 -14400 0 -04} + {2955931200 -10800 1 -04} + {2974676400 -14400 0 -04} + {2987985600 -10800 1 -04} + {3006126000 -14400 0 -04} + {3019435200 -10800 1 -04} + {3037575600 -14400 0 -04} + {3050884800 -10800 1 -04} + {3069025200 -14400 0 -04} + {3082334400 -10800 1 -04} + {3101079600 -14400 0 -04} + {3113784000 -10800 1 -04} + {3132529200 -14400 0 -04} + {3145838400 -10800 1 -04} + {3163978800 -14400 0 -04} + {3177288000 -10800 1 -04} + {3195428400 -14400 0 -04} + {3208737600 -10800 1 -04} + {3226878000 -14400 0 -04} + {3240187200 -10800 1 -04} + {3258327600 -14400 0 -04} + {3271636800 -10800 1 -04} + {3290382000 -14400 0 -04} + {3303086400 -10800 1 -04} + {3321831600 -14400 0 -04} + {3335140800 -10800 1 -04} + {3353281200 -14400 0 -04} + {3366590400 -10800 1 -04} + {3384730800 -14400 0 -04} + {3398040000 -10800 1 -04} + {3416180400 -14400 0 -04} + {3429489600 -10800 1 -04} + {3447630000 -14400 0 -04} + {3460939200 -10800 1 -04} + {3479684400 -14400 0 -04} + {3492993600 -10800 1 -04} + {3511134000 -14400 0 -04} + {3524443200 -10800 1 -04} + {3542583600 -14400 0 -04} + {3555892800 -10800 1 -04} + {3574033200 -14400 0 -04} + {3587342400 -10800 1 -04} + {3605482800 -14400 0 -04} + {3618792000 -10800 1 -04} + {3637537200 -14400 0 -04} + {3650241600 -10800 1 -04} + {3668986800 -14400 0 -04} + {3682296000 -10800 1 -04} + {3700436400 -14400 0 -04} + {3713745600 -10800 1 -04} + {3731886000 -14400 0 -04} + {3745195200 -10800 1 -04} + {3763335600 -14400 0 -04} + {3776644800 -10800 1 -04} + {3794785200 -14400 0 -04} + {3808094400 -10800 1 -04} + {3826839600 -14400 0 -04} + {3839544000 -10800 1 -04} + {3858289200 -14400 0 -04} + {3871598400 -10800 1 -04} + {3889738800 -14400 0 -04} + {3903048000 -10800 1 -04} + {3921188400 -14400 0 -04} + {3934497600 -10800 1 -04} + {3952638000 -14400 0 -04} + {3965947200 -10800 1 -04} + {3984692400 -14400 0 -04} + {3997396800 -10800 1 -04} + {4016142000 -14400 0 -04} + {4029451200 -10800 1 -04} + {4047591600 -14400 0 -04} + {4060900800 -10800 1 -04} + {4079041200 -14400 0 -04} + {4092350400 -10800 1 -04} } diff --git a/library/tzdata/Asia/Macau b/library/tzdata/Asia/Macau index 76a00aa..cbafd0e 100644 --- a/library/tzdata/Asia/Macau +++ b/library/tzdata/Asia/Macau @@ -1,20 +1,56 @@ # created by tools/tclZIC.tcl - do not edit set TZData(:Asia/Macau) { - {-9223372036854775808 27260 0 LMT} - {-1830412800 28800 0 CST} + {-9223372036854775808 27250 0 LMT} + {-2056692850 28800 0 CST} + {-884509200 32400 0 +09} + {-873280800 36000 1 +09} + {-855918000 32400 0 +09} + {-841744800 36000 1 +09} + {-828529200 32400 0 +10} + {-765363600 28800 0 CT} + {-747046800 32400 1 CDT} + {-733827600 28800 0 CST} + {-716461200 32400 1 CDT} + {-697021200 28800 0 CST} + {-683715600 32400 1 CDT} + {-667990800 28800 0 CST} + {-654771600 32400 1 CDT} + {-636627600 28800 0 CST} + {-623322000 32400 1 CDT} + {-605178000 28800 0 CST} + {-591872400 32400 1 CDT} + {-573642000 28800 0 CST} + {-559818000 32400 1 CDT} + {-541674000 28800 0 CST} + {-528368400 32400 1 CDT} + {-510224400 28800 0 CST} + {-498128400 32400 1 CDT} + {-478774800 28800 0 CST} + {-466678800 32400 1 CDT} + {-446720400 28800 0 CST} + {-435229200 32400 1 CDT} + {-415258200 28800 0 CST} + {-403158600 32400 1 CDT} + {-383808600 28800 0 CST} + {-371709000 32400 1 CDT} + {-352359000 28800 0 CST} + {-340259400 32400 1 CDT} + {-320909400 28800 0 CST} + {-308809800 32400 1 CDT} + {-288855000 28800 0 CST} {-277360200 32400 1 CDT} {-257405400 28800 0 CST} {-245910600 32400 1 CDT} {-225955800 28800 0 CST} - {-214473600 32400 1 CDT} + {-213856200 32400 1 CDT} {-194506200 28800 0 CST} {-182406600 32400 1 CDT} {-163056600 28800 0 CST} - {-150969600 32400 1 CDT} - {-131619600 28800 0 CST} + {-148537800 32400 1 CDT} + {-132820200 28800 0 CST} {-117088200 32400 1 CDT} - {-101367000 28800 0 CST} + {-101370600 28800 0 CST} {-85638600 32400 1 CDT} {-69312600 28800 0 CST} {-53584200 32400 1 CDT} @@ -25,22 +61,16 @@ set TZData(:Asia/Macau) { {25036200 28800 0 CST} {40764600 32400 1 CDT} {56485800 28800 0 CST} - {72201600 32400 1 CDT} - {87922800 28800 0 CST} - {103651200 32400 1 CDT} - {119977200 28800 0 CST} - {135705600 32400 1 CDT} + {72214200 32400 1 CDT} + {88540200 28800 0 CST} + {104268600 32400 1 CDT} + {119989800 28800 0 CST} + {126041400 32400 1 CDT} {151439400 28800 0 CST} {167167800 32400 1 CDT} {182889000 28800 0 CST} {198617400 32400 1 CDT} {214338600 28800 0 CST} - {230067000 32400 1 CDT} - {245788200 28800 0 CST} - {261504000 32400 1 CDT} - {277225200 28800 0 CST} - {292953600 32400 1 CDT} - {309279600 28800 0 CST} - {325008000 32400 1 CDT} - {340729200 28800 0 CST} + {295385400 32400 1 CDT} + {309292200 28800 0 CST} } diff --git a/library/tzdata/Asia/Manila b/library/tzdata/Asia/Manila index b7ffa7a..6eb1db3 100644 --- a/library/tzdata/Asia/Manila +++ b/library/tzdata/Asia/Manila @@ -3,13 +3,13 @@ set TZData(:Asia/Manila) { {-9223372036854775808 -57360 0 LMT} {-3944621040 29040 0 LMT} - {-2229321840 28800 0 +08} - {-1046678400 32400 1 +08} - {-1038733200 28800 0 +08} - {-873273600 32400 0 +09} - {-794221200 28800 0 +08} - {-496224000 32400 1 +08} - {-489315600 28800 0 +08} - {259344000 32400 1 +08} - {275151600 28800 0 +08} + {-2229321840 28800 0 PST} + {-1046678400 32400 1 PDT} + {-1038733200 28800 0 PST} + {-873273600 32400 0 JST} + {-794221200 28800 0 PST} + {-496224000 32400 1 PDT} + {-489315600 28800 0 PST} + {259344000 32400 1 PDT} + {275151600 28800 0 PST} } diff --git a/library/tzdata/Asia/Pyongyang b/library/tzdata/Asia/Pyongyang index 5746472..5351736 100644 --- a/library/tzdata/Asia/Pyongyang +++ b/library/tzdata/Asia/Pyongyang @@ -6,5 +6,5 @@ set TZData(:Asia/Pyongyang) { {-1830414600 32400 0 JST} {-768646800 32400 0 KST} {1439564400 30600 0 KST} - {1525447800 32400 0 KST} + {1525446000 32400 0 KST} } diff --git a/library/tzdata/Asia/Shanghai b/library/tzdata/Asia/Shanghai index ff2d2b5..66bc4339 100644 --- a/library/tzdata/Asia/Shanghai +++ b/library/tzdata/Asia/Shanghai @@ -3,21 +3,30 @@ set TZData(:Asia/Shanghai) { {-9223372036854775808 29143 0 LMT} {-2177481943 28800 0 CST} - {-933494400 32400 1 CDT} - {-923130000 28800 0 CST} - {-908784000 32400 1 CDT} - {-891594000 28800 0 CST} - {-662716800 28800 0 CST} - {515520000 32400 1 CDT} - {527007600 28800 0 CST} - {545155200 32400 1 CDT} - {558457200 28800 0 CST} - {576604800 32400 1 CDT} - {589906800 28800 0 CST} - {608659200 32400 1 CDT} - {621961200 28800 0 CST} - {640108800 32400 1 CDT} - {653410800 28800 0 CST} - {671558400 32400 1 CDT} - {684860400 28800 0 CST} + {-933667200 32400 1 CDT} + {-922093200 28800 0 CST} + {-908870400 32400 1 CDT} + {-888829200 28800 0 CST} + {-881049600 32400 1 CDT} + {-767869200 28800 0 CST} + {-745833600 32400 1 CDT} + {-733827600 28800 0 CST} + {-716889600 32400 1 CDT} + {-699613200 28800 0 CST} + {-683884800 32400 1 CDT} + {-670669200 28800 0 CST} + {-652348800 32400 1 CDT} + {-650016000 28800 0 CST} + {515527200 32400 1 CDT} + {527014800 28800 0 CST} + {545162400 32400 1 CDT} + {558464400 28800 0 CST} + {577216800 32400 1 CDT} + {589914000 28800 0 CST} + {608666400 32400 1 CDT} + {621968400 28800 0 CST} + {640116000 32400 1 CDT} + {653418000 28800 0 CST} + {671565600 32400 1 CDT} + {684867600 28800 0 CST} } diff --git a/library/tzdata/Asia/Tokyo b/library/tzdata/Asia/Tokyo index 790df0a..cc7a857 100644 --- a/library/tzdata/Asia/Tokyo +++ b/library/tzdata/Asia/Tokyo @@ -4,11 +4,11 @@ set TZData(:Asia/Tokyo) { {-9223372036854775808 33539 0 LMT} {-2587712400 32400 0 JST} {-683802000 36000 1 JDT} - {-672314400 32400 0 JST} + {-672310800 32400 0 JST} {-654771600 36000 1 JDT} - {-640864800 32400 0 JST} + {-640861200 32400 0 JST} {-620298000 36000 1 JDT} - {-609415200 32400 0 JST} + {-609411600 32400 0 JST} {-588848400 36000 1 JDT} - {-577965600 32400 0 JST} + {-577962000 32400 0 JST} } diff --git a/library/tzdata/Europe/Volgograd b/library/tzdata/Europe/Volgograd index 05e1044..3938683 100644 --- a/library/tzdata/Europe/Volgograd +++ b/library/tzdata/Europe/Volgograd @@ -68,4 +68,5 @@ set TZData(:Europe/Volgograd) { {1288479600 10800 0 +03} {1301180400 14400 0 +04} {1414274400 10800 0 +03} + {1540681200 14400 0 +04} } diff --git a/library/tzdata/Pacific/Easter b/library/tzdata/Pacific/Easter index a087cd0..7a8d525 100644 --- a/library/tzdata/Pacific/Easter +++ b/library/tzdata/Pacific/Easter @@ -103,166 +103,166 @@ set TZData(:Pacific/Easter) { {1502596800 -18000 1 -06} {1526180400 -21600 0 -06} {1534046400 -18000 1 -06} - {1557630000 -21600 0 -06} - {1565496000 -18000 1 -06} - {1589079600 -21600 0 -06} - {1596945600 -18000 1 -06} - {1620529200 -21600 0 -06} - {1629000000 -18000 1 -06} - {1652583600 -21600 0 -06} - {1660449600 -18000 1 -06} - {1684033200 -21600 0 -06} - {1691899200 -18000 1 -06} - {1715482800 -21600 0 -06} - {1723348800 -18000 1 -06} - {1746932400 -21600 0 -06} - {1754798400 -18000 1 -06} - {1778382000 -21600 0 -06} - {1786248000 -18000 1 -06} - {1809831600 -21600 0 -06} - {1818302400 -18000 1 -06} - {1841886000 -21600 0 -06} - {1849752000 -18000 1 -06} - {1873335600 -21600 0 -06} - {1881201600 -18000 1 -06} - {1904785200 -21600 0 -06} - {1912651200 -18000 1 -06} - {1936234800 -21600 0 -06} - {1944100800 -18000 1 -06} - {1967684400 -21600 0 -06} - {1976155200 -18000 1 -06} - {1999738800 -21600 0 -06} - {2007604800 -18000 1 -06} - {2031188400 -21600 0 -06} - {2039054400 -18000 1 -06} - {2062638000 -21600 0 -06} - {2070504000 -18000 1 -06} - {2094087600 -21600 0 -06} - {2101953600 -18000 1 -06} - {2125537200 -21600 0 -06} - {2133403200 -18000 1 -06} - {2156986800 -21600 0 -06} - {2165457600 -18000 1 -06} - {2189041200 -21600 0 -06} - {2196907200 -18000 1 -06} - {2220490800 -21600 0 -06} - {2228356800 -18000 1 -06} - {2251940400 -21600 0 -06} - {2259806400 -18000 1 -06} - {2283390000 -21600 0 -06} - {2291256000 -18000 1 -06} - {2314839600 -21600 0 -06} - {2322705600 -18000 1 -06} - {2346894000 -21600 0 -06} - {2354760000 -18000 1 -06} - {2378343600 -21600 0 -06} - {2386209600 -18000 1 -06} - {2409793200 -21600 0 -06} - {2417659200 -18000 1 -06} - {2441242800 -21600 0 -06} - {2449108800 -18000 1 -06} - {2472692400 -21600 0 -06} - {2480558400 -18000 1 -06} - {2504142000 -21600 0 -06} - {2512612800 -18000 1 -06} - {2536196400 -21600 0 -06} - {2544062400 -18000 1 -06} - {2567646000 -21600 0 -06} - {2575512000 -18000 1 -06} - {2599095600 -21600 0 -06} - {2606961600 -18000 1 -06} - {2630545200 -21600 0 -06} - {2638411200 -18000 1 -06} - {2661994800 -21600 0 -06} - {2669860800 -18000 1 -06} - {2693444400 -21600 0 -06} - {2701915200 -18000 1 -06} - {2725498800 -21600 0 -06} - {2733364800 -18000 1 -06} - {2756948400 -21600 0 -06} - {2764814400 -18000 1 -06} - {2788398000 -21600 0 -06} - {2796264000 -18000 1 -06} - {2819847600 -21600 0 -06} - {2827713600 -18000 1 -06} - {2851297200 -21600 0 -06} - {2859768000 -18000 1 -06} - {2883351600 -21600 0 -06} - {2891217600 -18000 1 -06} - {2914801200 -21600 0 -06} - {2922667200 -18000 1 -06} - {2946250800 -21600 0 -06} - {2954116800 -18000 1 -06} - {2977700400 -21600 0 -06} - {2985566400 -18000 1 -06} - {3009150000 -21600 0 -06} - {3017016000 -18000 1 -06} - {3040599600 -21600 0 -06} - {3049070400 -18000 1 -06} - {3072654000 -21600 0 -06} - {3080520000 -18000 1 -06} - {3104103600 -21600 0 -06} - {3111969600 -18000 1 -06} - {3135553200 -21600 0 -06} - {3143419200 -18000 1 -06} - {3167002800 -21600 0 -06} - {3174868800 -18000 1 -06} - {3198452400 -21600 0 -06} - {3206318400 -18000 1 -06} - {3230506800 -21600 0 -06} - {3238372800 -18000 1 -06} - {3261956400 -21600 0 -06} - {3269822400 -18000 1 -06} - {3293406000 -21600 0 -06} - {3301272000 -18000 1 -06} - {3324855600 -21600 0 -06} - {3332721600 -18000 1 -06} - {3356305200 -21600 0 -06} - {3364171200 -18000 1 -06} - {3387754800 -21600 0 -06} - {3396225600 -18000 1 -06} - {3419809200 -21600 0 -06} - {3427675200 -18000 1 -06} - {3451258800 -21600 0 -06} - {3459124800 -18000 1 -06} - {3482708400 -21600 0 -06} - {3490574400 -18000 1 -06} - {3514158000 -21600 0 -06} - {3522024000 -18000 1 -06} - {3545607600 -21600 0 -06} - {3553473600 -18000 1 -06} - {3577057200 -21600 0 -06} - {3585528000 -18000 1 -06} - {3609111600 -21600 0 -06} - {3616977600 -18000 1 -06} - {3640561200 -21600 0 -06} - {3648427200 -18000 1 -06} - {3672010800 -21600 0 -06} - {3679876800 -18000 1 -06} - {3703460400 -21600 0 -06} - {3711326400 -18000 1 -06} - {3734910000 -21600 0 -06} - {3743380800 -18000 1 -06} - {3766964400 -21600 0 -06} - {3774830400 -18000 1 -06} - {3798414000 -21600 0 -06} - {3806280000 -18000 1 -06} - {3829863600 -21600 0 -06} - {3837729600 -18000 1 -06} - {3861313200 -21600 0 -06} - {3869179200 -18000 1 -06} - {3892762800 -21600 0 -06} - {3900628800 -18000 1 -06} - {3924212400 -21600 0 -06} - {3932683200 -18000 1 -06} - {3956266800 -21600 0 -06} - {3964132800 -18000 1 -06} - {3987716400 -21600 0 -06} - {3995582400 -18000 1 -06} - {4019166000 -21600 0 -06} - {4027032000 -18000 1 -06} - {4050615600 -21600 0 -06} - {4058481600 -18000 1 -06} - {4082065200 -21600 0 -06} - {4089931200 -18000 1 -06} + {1554606000 -21600 0 -06} + {1567915200 -18000 1 -06} + {1586055600 -21600 0 -06} + {1599364800 -18000 1 -06} + {1617505200 -21600 0 -06} + {1630814400 -18000 1 -06} + {1648954800 -21600 0 -06} + {1662264000 -18000 1 -06} + {1680404400 -21600 0 -06} + {1693713600 -18000 1 -06} + {1712458800 -21600 0 -06} + {1725768000 -18000 1 -06} + {1743908400 -21600 0 -06} + {1757217600 -18000 1 -06} + {1775358000 -21600 0 -06} + {1788667200 -18000 1 -06} + {1806807600 -21600 0 -06} + {1820116800 -18000 1 -06} + {1838257200 -21600 0 -06} + {1851566400 -18000 1 -06} + {1870311600 -21600 0 -06} + {1883016000 -18000 1 -06} + {1901761200 -21600 0 -06} + {1915070400 -18000 1 -06} + {1933210800 -21600 0 -06} + {1946520000 -18000 1 -06} + {1964660400 -21600 0 -06} + {1977969600 -18000 1 -06} + {1996110000 -21600 0 -06} + {2009419200 -18000 1 -06} + {2027559600 -21600 0 -06} + {2040868800 -18000 1 -06} + {2059614000 -21600 0 -06} + {2072318400 -18000 1 -06} + {2091063600 -21600 0 -06} + {2104372800 -18000 1 -06} + {2122513200 -21600 0 -06} + {2135822400 -18000 1 -06} + {2153962800 -21600 0 -06} + {2167272000 -18000 1 -06} + {2185412400 -21600 0 -06} + {2198721600 -18000 1 -06} + {2217466800 -21600 0 -06} + {2230171200 -18000 1 -06} + {2248916400 -21600 0 -06} + {2262225600 -18000 1 -06} + {2280366000 -21600 0 -06} + {2293675200 -18000 1 -06} + {2311815600 -21600 0 -06} + {2325124800 -18000 1 -06} + {2343265200 -21600 0 -06} + {2356574400 -18000 1 -06} + {2374714800 -21600 0 -06} + {2388024000 -18000 1 -06} + {2406769200 -21600 0 -06} + {2419473600 -18000 1 -06} + {2438218800 -21600 0 -06} + {2451528000 -18000 1 -06} + {2469668400 -21600 0 -06} + {2482977600 -18000 1 -06} + {2501118000 -21600 0 -06} + {2514427200 -18000 1 -06} + {2532567600 -21600 0 -06} + {2545876800 -18000 1 -06} + {2564017200 -21600 0 -06} + {2577326400 -18000 1 -06} + {2596071600 -21600 0 -06} + {2609380800 -18000 1 -06} + {2627521200 -21600 0 -06} + {2640830400 -18000 1 -06} + {2658970800 -21600 0 -06} + {2672280000 -18000 1 -06} + {2690420400 -21600 0 -06} + {2703729600 -18000 1 -06} + {2721870000 -21600 0 -06} + {2735179200 -18000 1 -06} + {2753924400 -21600 0 -06} + {2766628800 -18000 1 -06} + {2785374000 -21600 0 -06} + {2798683200 -18000 1 -06} + {2816823600 -21600 0 -06} + {2830132800 -18000 1 -06} + {2848273200 -21600 0 -06} + {2861582400 -18000 1 -06} + {2879722800 -21600 0 -06} + {2893032000 -18000 1 -06} + {2911172400 -21600 0 -06} + {2924481600 -18000 1 -06} + {2943226800 -21600 0 -06} + {2955931200 -18000 1 -06} + {2974676400 -21600 0 -06} + {2987985600 -18000 1 -06} + {3006126000 -21600 0 -06} + {3019435200 -18000 1 -06} + {3037575600 -21600 0 -06} + {3050884800 -18000 1 -06} + {3069025200 -21600 0 -06} + {3082334400 -18000 1 -06} + {3101079600 -21600 0 -06} + {3113784000 -18000 1 -06} + {3132529200 -21600 0 -06} + {3145838400 -18000 1 -06} + {3163978800 -21600 0 -06} + {3177288000 -18000 1 -06} + {3195428400 -21600 0 -06} + {3208737600 -18000 1 -06} + {3226878000 -21600 0 -06} + {3240187200 -18000 1 -06} + {3258327600 -21600 0 -06} + {3271636800 -18000 1 -06} + {3290382000 -21600 0 -06} + {3303086400 -18000 1 -06} + {3321831600 -21600 0 -06} + {3335140800 -18000 1 -06} + {3353281200 -21600 0 -06} + {3366590400 -18000 1 -06} + {3384730800 -21600 0 -06} + {3398040000 -18000 1 -06} + {3416180400 -21600 0 -06} + {3429489600 -18000 1 -06} + {3447630000 -21600 0 -06} + {3460939200 -18000 1 -06} + {3479684400 -21600 0 -06} + {3492993600 -18000 1 -06} + {3511134000 -21600 0 -06} + {3524443200 -18000 1 -06} + {3542583600 -21600 0 -06} + {3555892800 -18000 1 -06} + {3574033200 -21600 0 -06} + {3587342400 -18000 1 -06} + {3605482800 -21600 0 -06} + {3618792000 -18000 1 -06} + {3637537200 -21600 0 -06} + {3650241600 -18000 1 -06} + {3668986800 -21600 0 -06} + {3682296000 -18000 1 -06} + {3700436400 -21600 0 -06} + {3713745600 -18000 1 -06} + {3731886000 -21600 0 -06} + {3745195200 -18000 1 -06} + {3763335600 -21600 0 -06} + {3776644800 -18000 1 -06} + {3794785200 -21600 0 -06} + {3808094400 -18000 1 -06} + {3826839600 -21600 0 -06} + {3839544000 -18000 1 -06} + {3858289200 -21600 0 -06} + {3871598400 -18000 1 -06} + {3889738800 -21600 0 -06} + {3903048000 -18000 1 -06} + {3921188400 -21600 0 -06} + {3934497600 -18000 1 -06} + {3952638000 -21600 0 -06} + {3965947200 -18000 1 -06} + {3984692400 -21600 0 -06} + {3997396800 -18000 1 -06} + {4016142000 -21600 0 -06} + {4029451200 -18000 1 -06} + {4047591600 -21600 0 -06} + {4060900800 -18000 1 -06} + {4079041200 -21600 0 -06} + {4092350400 -18000 1 -06} } diff --git a/library/tzdata/Pacific/Fiji b/library/tzdata/Pacific/Fiji index 610c191..b05985c 100644 --- a/library/tzdata/Pacific/Fiji +++ b/library/tzdata/Pacific/Fiji @@ -26,7 +26,7 @@ set TZData(:Pacific/Fiji) { {1509804000 46800 1 +12} {1515852000 43200 0 +12} {1541253600 46800 1 +12} - {1547906400 43200 0 +12} + {1547301600 43200 0 +12} {1572703200 46800 1 +12} {1579356000 43200 0 +12} {1604152800 46800 1 +12} @@ -48,7 +48,7 @@ set TZData(:Pacific/Fiji) { {1856959200 46800 1 +12} {1863007200 43200 0 +12} {1888408800 46800 1 +12} - {1895061600 43200 0 +12} + {1894456800 43200 0 +12} {1919858400 46800 1 +12} {1926511200 43200 0 +12} {1951308000 46800 1 +12} @@ -60,7 +60,7 @@ set TZData(:Pacific/Fiji) { {2046261600 46800 1 +12} {2052309600 43200 0 +12} {2077711200 46800 1 +12} - {2084364000 43200 0 +12} + {2083759200 43200 0 +12} {2109160800 46800 1 +12} {2115813600 43200 0 +12} {2140610400 46800 1 +12} @@ -70,7 +70,7 @@ set TZData(:Pacific/Fiji) { {2204114400 46800 1 +12} {2210162400 43200 0 +12} {2235564000 46800 1 +12} - {2242216800 43200 0 +12} + {2241612000 43200 0 +12} {2267013600 46800 1 +12} {2273666400 43200 0 +12} {2298463200 46800 1 +12} @@ -82,7 +82,7 @@ set TZData(:Pacific/Fiji) { {2393416800 46800 1 +12} {2399464800 43200 0 +12} {2424866400 46800 1 +12} - {2431519200 43200 0 +12} + {2430914400 43200 0 +12} {2456316000 46800 1 +12} {2462968800 43200 0 +12} {2487765600 46800 1 +12} @@ -104,7 +104,7 @@ set TZData(:Pacific/Fiji) { {2740572000 46800 1 +12} {2746620000 43200 0 +12} {2772021600 46800 1 +12} - {2778674400 43200 0 +12} + {2778069600 43200 0 +12} {2803471200 46800 1 +12} {2810124000 43200 0 +12} {2834920800 46800 1 +12} @@ -116,7 +116,7 @@ set TZData(:Pacific/Fiji) { {2929874400 46800 1 +12} {2935922400 43200 0 +12} {2961324000 46800 1 +12} - {2967976800 43200 0 +12} + {2967372000 43200 0 +12} {2992773600 46800 1 +12} {2999426400 43200 0 +12} {3024223200 46800 1 +12} @@ -126,7 +126,7 @@ set TZData(:Pacific/Fiji) { {3087727200 46800 1 +12} {3093775200 43200 0 +12} {3119176800 46800 1 +12} - {3125829600 43200 0 +12} + {3125224800 43200 0 +12} {3150626400 46800 1 +12} {3157279200 43200 0 +12} {3182076000 46800 1 +12} @@ -138,7 +138,7 @@ set TZData(:Pacific/Fiji) { {3277029600 46800 1 +12} {3283077600 43200 0 +12} {3308479200 46800 1 +12} - {3315132000 43200 0 +12} + {3314527200 43200 0 +12} {3339928800 46800 1 +12} {3346581600 43200 0 +12} {3371378400 46800 1 +12} @@ -160,7 +160,7 @@ set TZData(:Pacific/Fiji) { {3624184800 46800 1 +12} {3630232800 43200 0 +12} {3655634400 46800 1 +12} - {3662287200 43200 0 +12} + {3661682400 43200 0 +12} {3687084000 46800 1 +12} {3693736800 43200 0 +12} {3718533600 46800 1 +12} @@ -172,7 +172,7 @@ set TZData(:Pacific/Fiji) { {3813487200 46800 1 +12} {3819535200 43200 0 +12} {3844936800 46800 1 +12} - {3851589600 43200 0 +12} + {3850984800 43200 0 +12} {3876386400 46800 1 +12} {3883039200 43200 0 +12} {3907836000 46800 1 +12} @@ -182,7 +182,7 @@ set TZData(:Pacific/Fiji) { {3971340000 46800 1 +12} {3977388000 43200 0 +12} {4002789600 46800 1 +12} - {4009442400 43200 0 +12} + {4008837600 43200 0 +12} {4034239200 46800 1 +12} {4040892000 43200 0 +12} {4065688800 46800 1 +12} -- cgit v0.12 From 5f392f74b688af273b3efd7f1a6a073f3c24dcb1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jos=C3=A9=20Ignacio=20Mar=C3=ADn?= Date: Sat, 27 Oct 2018 18:07:35 +0000 Subject: Update TZ info to tzdata2018g. --- library/tzdata/Africa/Casablanca | 280 ++++++++------------------------------- library/tzdata/Africa/El_Aaiun | 256 ++++++----------------------------- library/tzdata/Pacific/Honolulu | 5 +- 3 files changed, 101 insertions(+), 440 deletions(-) diff --git a/library/tzdata/Africa/Casablanca b/library/tzdata/Africa/Casablanca index 33ad99b..3207e59 100644 --- a/library/tzdata/Africa/Casablanca +++ b/library/tzdata/Africa/Casablanca @@ -2,229 +2,59 @@ set TZData(:Africa/Casablanca) { {-9223372036854775808 -1820 0 LMT} - {-1773012580 0 0 WET} - {-956361600 3600 1 WEST} - {-950490000 0 0 WET} - {-942019200 3600 1 WEST} - {-761187600 0 0 WET} - {-617241600 3600 1 WEST} - {-605149200 0 0 WET} - {-81432000 3600 1 WEST} - {-71110800 0 0 WET} - {141264000 3600 1 WEST} - {147222000 0 0 WET} - {199756800 3600 1 WEST} - {207702000 0 0 WET} - {231292800 3600 1 WEST} - {244249200 0 0 WET} - {265507200 3600 1 WEST} - {271033200 0 0 WET} - {448243200 3600 0 CET} - {504918000 0 0 WET} - {1212278400 3600 1 WEST} - {1220223600 0 0 WET} - {1243814400 3600 1 WEST} - {1250809200 0 0 WET} - {1272758400 3600 1 WEST} - {1281222000 0 0 WET} - {1301788800 3600 1 WEST} - {1312066800 0 0 WET} - {1335664800 3600 1 WEST} - {1342749600 0 0 WET} - {1345428000 3600 1 WEST} - {1348970400 0 0 WET} - {1367114400 3600 1 WEST} - {1373162400 0 0 WET} - {1376100000 3600 1 WEST} - {1382839200 0 0 WET} - {1396144800 3600 1 WEST} - {1403920800 0 0 WET} - {1406944800 3600 1 WEST} - {1414288800 0 0 WET} - {1427594400 3600 1 WEST} - {1434247200 0 0 WET} - {1437271200 3600 1 WEST} - {1445738400 0 0 WET} - {1459044000 3600 1 WEST} - {1465092000 0 0 WET} - {1468116000 3600 1 WEST} - {1477792800 0 0 WET} - {1490493600 3600 1 WEST} - {1495332000 0 0 WET} - {1498960800 3600 1 WEST} - {1509242400 0 0 WET} - {1521943200 3600 1 WEST} - {1526176800 0 0 WET} - {1529200800 3600 1 WEST} - {1540692000 0 0 WET} - {1553997600 3600 1 WEST} - {1557021600 0 0 WET} - {1560045600 3600 1 WEST} - {1572141600 0 0 WET} - {1585447200 3600 1 WEST} - {1587261600 0 0 WET} - {1590285600 3600 1 WEST} - {1603591200 0 0 WET} - {1616896800 3600 1 WEST} - {1618106400 0 0 WET} - {1621130400 3600 1 WEST} - {1635645600 0 0 WET} - {1651975200 3600 1 WEST} - {1667095200 0 0 WET} - {1682215200 3600 1 WEST} - {1698544800 0 0 WET} - {1713060000 3600 1 WEST} - {1729994400 0 0 WET} - {1743904800 3600 1 WEST} - {1761444000 0 0 WET} - {1774749600 3600 1 WEST} - {1792893600 0 0 WET} - {1806199200 3600 1 WEST} - {1824948000 0 0 WET} - {1837648800 3600 1 WEST} - {1856397600 0 0 WET} - {1869098400 3600 1 WEST} - {1887847200 0 0 WET} - {1901152800 3600 1 WEST} - {1919296800 0 0 WET} - {1932602400 3600 1 WEST} - {1950746400 0 0 WET} - {1964052000 3600 1 WEST} - {1982800800 0 0 WET} - {1995501600 3600 1 WEST} - {2014250400 0 0 WET} - {2026951200 3600 1 WEST} - {2045700000 0 0 WET} - {2058400800 3600 1 WEST} - {2077149600 0 0 WET} - {2090455200 3600 1 WEST} - {2107994400 0 0 WET} - {2108602800 0 0 WET} - {2121904800 3600 1 WEST} - {2138234400 0 0 WET} - {2140052400 0 0 WET} - {2153354400 3600 1 WEST} - {2172103200 0 0 WET} - {2184804000 3600 1 WEST} - {2203552800 0 0 WET} - {2216253600 3600 1 WEST} - {2235002400 0 0 WET} - {2248308000 3600 1 WEST} - {2266452000 0 0 WET} - {2279757600 3600 1 WEST} - {2297901600 0 0 WET} - {2311207200 3600 1 WEST} - {2329351200 0 0 WET} - {2342656800 3600 1 WEST} - {2361405600 0 0 WET} - {2374106400 3600 1 WEST} - {2392855200 0 0 WET} - {2405556000 3600 1 WEST} - {2424304800 0 0 WET} - {2437610400 3600 1 WEST} - {2455754400 0 0 WET} - {2469060000 3600 1 WEST} - {2487204000 0 0 WET} - {2500509600 3600 1 WEST} - {2519258400 0 0 WET} - {2531959200 3600 1 WEST} - {2550708000 0 0 WET} - {2563408800 3600 1 WEST} - {2582157600 0 0 WET} - {2595463200 3600 1 WEST} - {2613607200 0 0 WET} - {2626912800 3600 1 WEST} - {2645056800 0 0 WET} - {2658362400 3600 1 WEST} - {2676506400 0 0 WET} - {2689812000 3600 1 WEST} - {2708560800 0 0 WET} - {2721261600 3600 1 WEST} - {2740010400 0 0 WET} - {2752711200 3600 1 WEST} - {2771460000 0 0 WET} - {2784765600 3600 1 WEST} - {2802909600 0 0 WET} - {2816215200 3600 1 WEST} - {2834359200 0 0 WET} - {2847664800 3600 1 WEST} - {2866413600 0 0 WET} - {2879114400 3600 1 WEST} - {2897863200 0 0 WET} - {2910564000 3600 1 WEST} - {2929312800 0 0 WET} - {2942013600 3600 1 WEST} - {2960762400 0 0 WET} - {2974068000 3600 1 WEST} - {2992212000 0 0 WET} - {3005517600 3600 1 WEST} - {3023661600 0 0 WET} - {3036967200 3600 1 WEST} - {3055716000 0 0 WET} - {3068416800 3600 1 WEST} - {3087165600 0 0 WET} - {3099866400 3600 1 WEST} - {3118615200 0 0 WET} - {3131920800 3600 1 WEST} - {3150064800 0 0 WET} - {3163370400 3600 1 WEST} - {3181514400 0 0 WET} - {3194820000 3600 1 WEST} - {3212964000 0 0 WET} - {3226269600 3600 1 WEST} - {3245018400 0 0 WET} - {3257719200 3600 1 WEST} - {3276468000 0 0 WET} - {3289168800 3600 1 WEST} - {3307917600 0 0 WET} - {3321223200 3600 1 WEST} - {3339367200 0 0 WET} - {3352672800 3600 1 WEST} - {3370816800 0 0 WET} - {3384122400 3600 1 WEST} - {3402871200 0 0 WET} - {3415572000 3600 1 WEST} - {3434320800 0 0 WET} - {3447021600 3600 1 WEST} - {3465770400 0 0 WET} - {3479076000 3600 1 WEST} - {3497220000 0 0 WET} - {3510525600 3600 1 WEST} - {3528669600 0 0 WET} - {3541975200 3600 1 WEST} - {3560119200 0 0 WET} - {3573424800 3600 1 WEST} - {3592173600 0 0 WET} - {3604874400 3600 1 WEST} - {3623623200 0 0 WET} - {3636324000 3600 1 WEST} - {3655072800 0 0 WET} - {3668378400 3600 1 WEST} - {3686522400 0 0 WET} - {3699828000 3600 1 WEST} - {3717972000 0 0 WET} - {3731277600 3600 1 WEST} - {3750026400 0 0 WET} - {3762727200 3600 1 WEST} - {3781476000 0 0 WET} - {3794176800 3600 1 WEST} - {3812925600 0 0 WET} - {3825626400 3600 1 WEST} - {3844375200 0 0 WET} - {3857680800 3600 1 WEST} - {3875824800 0 0 WET} - {3889130400 3600 1 WEST} - {3907274400 0 0 WET} - {3920580000 3600 1 WEST} - {3939328800 0 0 WET} - {3952029600 3600 1 WEST} - {3970778400 0 0 WET} - {3983479200 3600 1 WEST} - {4002228000 0 0 WET} - {4015533600 3600 1 WEST} - {4033677600 0 0 WET} - {4046983200 3600 1 WEST} - {4065127200 0 0 WET} - {4078432800 3600 1 WEST} - {4096576800 0 0 WET} + {-1773012580 0 0 +00} + {-956361600 3600 1 +00} + {-950490000 0 0 +00} + {-942019200 3600 1 +00} + {-761187600 0 0 +00} + {-617241600 3600 1 +00} + {-605149200 0 0 +00} + {-81432000 3600 1 +00} + {-71110800 0 0 +00} + {141264000 3600 1 +00} + {147222000 0 0 +00} + {199756800 3600 1 +00} + {207702000 0 0 +00} + {231292800 3600 1 +00} + {244249200 0 0 +00} + {265507200 3600 1 +00} + {271033200 0 0 +00} + {448243200 3600 0 +01} + {504918000 0 0 +00} + {1212278400 3600 1 +00} + {1220223600 0 0 +00} + {1243814400 3600 1 +00} + {1250809200 0 0 +00} + {1272758400 3600 1 +00} + {1281222000 0 0 +00} + {1301788800 3600 1 +00} + {1312066800 0 0 +00} + {1335664800 3600 1 +00} + {1342749600 0 0 +00} + {1345428000 3600 1 +00} + {1348970400 0 0 +00} + {1367114400 3600 1 +00} + {1373162400 0 0 +00} + {1376100000 3600 1 +00} + {1382839200 0 0 +00} + {1396144800 3600 1 +00} + {1403920800 0 0 +00} + {1406944800 3600 1 +00} + {1414288800 0 0 +00} + {1427594400 3600 1 +00} + {1434247200 0 0 +00} + {1437271200 3600 1 +00} + {1445738400 0 0 +00} + {1459044000 3600 1 +00} + {1465092000 0 0 +00} + {1468116000 3600 1 +00} + {1477792800 0 0 +00} + {1490493600 3600 1 +00} + {1495332000 0 0 +00} + {1498960800 3600 1 +00} + {1509242400 0 0 +00} + {1521943200 3600 1 +00} + {1526176800 0 0 +00} + {1529200800 3600 1 +00} + {1540598400 3600 0 +01} } diff --git a/library/tzdata/Africa/El_Aaiun b/library/tzdata/Africa/El_Aaiun index 7bdc496..e0f5e1c 100644 --- a/library/tzdata/Africa/El_Aaiun +++ b/library/tzdata/Africa/El_Aaiun @@ -3,217 +3,47 @@ set TZData(:Africa/El_Aaiun) { {-9223372036854775808 -3168 0 LMT} {-1136070432 -3600 0 -01} - {198291600 0 0 WET} - {199756800 3600 1 WEST} - {207702000 0 0 WET} - {231292800 3600 1 WEST} - {244249200 0 0 WET} - {265507200 3600 1 WEST} - {271033200 0 0 WET} - {1212278400 3600 1 WEST} - {1220223600 0 0 WET} - {1243814400 3600 1 WEST} - {1250809200 0 0 WET} - {1272758400 3600 1 WEST} - {1281222000 0 0 WET} - {1301788800 3600 1 WEST} - {1312066800 0 0 WET} - {1335664800 3600 1 WEST} - {1342749600 0 0 WET} - {1345428000 3600 1 WEST} - {1348970400 0 0 WET} - {1367114400 3600 1 WEST} - {1373162400 0 0 WET} - {1376100000 3600 1 WEST} - {1382839200 0 0 WET} - {1396144800 3600 1 WEST} - {1403920800 0 0 WET} - {1406944800 3600 1 WEST} - {1414288800 0 0 WET} - {1427594400 3600 1 WEST} - {1434247200 0 0 WET} - {1437271200 3600 1 WEST} - {1445738400 0 0 WET} - {1459044000 3600 1 WEST} - {1465092000 0 0 WET} - {1468116000 3600 1 WEST} - {1477792800 0 0 WET} - {1490493600 3600 1 WEST} - {1495332000 0 0 WET} - {1498960800 3600 1 WEST} - {1509242400 0 0 WET} - {1521943200 3600 1 WEST} - {1526176800 0 0 WET} - {1529200800 3600 1 WEST} - {1540692000 0 0 WET} - {1553997600 3600 1 WEST} - {1557021600 0 0 WET} - {1560045600 3600 1 WEST} - {1572141600 0 0 WET} - {1585447200 3600 1 WEST} - {1587261600 0 0 WET} - {1590285600 3600 1 WEST} - {1603591200 0 0 WET} - {1616896800 3600 1 WEST} - {1618106400 0 0 WET} - {1621130400 3600 1 WEST} - {1635645600 0 0 WET} - {1651975200 3600 1 WEST} - {1667095200 0 0 WET} - {1682215200 3600 1 WEST} - {1698544800 0 0 WET} - {1713060000 3600 1 WEST} - {1729994400 0 0 WET} - {1743904800 3600 1 WEST} - {1761444000 0 0 WET} - {1774749600 3600 1 WEST} - {1792893600 0 0 WET} - {1806199200 3600 1 WEST} - {1824948000 0 0 WET} - {1837648800 3600 1 WEST} - {1856397600 0 0 WET} - {1869098400 3600 1 WEST} - {1887847200 0 0 WET} - {1901152800 3600 1 WEST} - {1919296800 0 0 WET} - {1932602400 3600 1 WEST} - {1950746400 0 0 WET} - {1964052000 3600 1 WEST} - {1982800800 0 0 WET} - {1995501600 3600 1 WEST} - {2014250400 0 0 WET} - {2026951200 3600 1 WEST} - {2045700000 0 0 WET} - {2058400800 3600 1 WEST} - {2077149600 0 0 WET} - {2090455200 3600 1 WEST} - {2107994400 0 0 WET} - {2108602800 0 0 WET} - {2121904800 3600 1 WEST} - {2138234400 0 0 WET} - {2140052400 0 0 WET} - {2153354400 3600 1 WEST} - {2172103200 0 0 WET} - {2184804000 3600 1 WEST} - {2203552800 0 0 WET} - {2216253600 3600 1 WEST} - {2235002400 0 0 WET} - {2248308000 3600 1 WEST} - {2266452000 0 0 WET} - {2279757600 3600 1 WEST} - {2297901600 0 0 WET} - {2311207200 3600 1 WEST} - {2329351200 0 0 WET} - {2342656800 3600 1 WEST} - {2361405600 0 0 WET} - {2374106400 3600 1 WEST} - {2392855200 0 0 WET} - {2405556000 3600 1 WEST} - {2424304800 0 0 WET} - {2437610400 3600 1 WEST} - {2455754400 0 0 WET} - {2469060000 3600 1 WEST} - {2487204000 0 0 WET} - {2500509600 3600 1 WEST} - {2519258400 0 0 WET} - {2531959200 3600 1 WEST} - {2550708000 0 0 WET} - {2563408800 3600 1 WEST} - {2582157600 0 0 WET} - {2595463200 3600 1 WEST} - {2613607200 0 0 WET} - {2626912800 3600 1 WEST} - {2645056800 0 0 WET} - {2658362400 3600 1 WEST} - {2676506400 0 0 WET} - {2689812000 3600 1 WEST} - {2708560800 0 0 WET} - {2721261600 3600 1 WEST} - {2740010400 0 0 WET} - {2752711200 3600 1 WEST} - {2771460000 0 0 WET} - {2784765600 3600 1 WEST} - {2802909600 0 0 WET} - {2816215200 3600 1 WEST} - {2834359200 0 0 WET} - {2847664800 3600 1 WEST} - {2866413600 0 0 WET} - {2879114400 3600 1 WEST} - {2897863200 0 0 WET} - {2910564000 3600 1 WEST} - {2929312800 0 0 WET} - {2942013600 3600 1 WEST} - {2960762400 0 0 WET} - {2974068000 3600 1 WEST} - {2992212000 0 0 WET} - {3005517600 3600 1 WEST} - {3023661600 0 0 WET} - {3036967200 3600 1 WEST} - {3055716000 0 0 WET} - {3068416800 3600 1 WEST} - {3087165600 0 0 WET} - {3099866400 3600 1 WEST} - {3118615200 0 0 WET} - {3131920800 3600 1 WEST} - {3150064800 0 0 WET} - {3163370400 3600 1 WEST} - {3181514400 0 0 WET} - {3194820000 3600 1 WEST} - {3212964000 0 0 WET} - {3226269600 3600 1 WEST} - {3245018400 0 0 WET} - {3257719200 3600 1 WEST} - {3276468000 0 0 WET} - {3289168800 3600 1 WEST} - {3307917600 0 0 WET} - {3321223200 3600 1 WEST} - {3339367200 0 0 WET} - {3352672800 3600 1 WEST} - {3370816800 0 0 WET} - {3384122400 3600 1 WEST} - {3402871200 0 0 WET} - {3415572000 3600 1 WEST} - {3434320800 0 0 WET} - {3447021600 3600 1 WEST} - {3465770400 0 0 WET} - {3479076000 3600 1 WEST} - {3497220000 0 0 WET} - {3510525600 3600 1 WEST} - {3528669600 0 0 WET} - {3541975200 3600 1 WEST} - {3560119200 0 0 WET} - {3573424800 3600 1 WEST} - {3592173600 0 0 WET} - {3604874400 3600 1 WEST} - {3623623200 0 0 WET} - {3636324000 3600 1 WEST} - {3655072800 0 0 WET} - {3668378400 3600 1 WEST} - {3686522400 0 0 WET} - {3699828000 3600 1 WEST} - {3717972000 0 0 WET} - {3731277600 3600 1 WEST} - {3750026400 0 0 WET} - {3762727200 3600 1 WEST} - {3781476000 0 0 WET} - {3794176800 3600 1 WEST} - {3812925600 0 0 WET} - {3825626400 3600 1 WEST} - {3844375200 0 0 WET} - {3857680800 3600 1 WEST} - {3875824800 0 0 WET} - {3889130400 3600 1 WEST} - {3907274400 0 0 WET} - {3920580000 3600 1 WEST} - {3939328800 0 0 WET} - {3952029600 3600 1 WEST} - {3970778400 0 0 WET} - {3983479200 3600 1 WEST} - {4002228000 0 0 WET} - {4015533600 3600 1 WEST} - {4033677600 0 0 WET} - {4046983200 3600 1 WEST} - {4065127200 0 0 WET} - {4078432800 3600 1 WEST} - {4096576800 0 0 WET} + {198291600 0 0 +00} + {199756800 3600 1 +00} + {207702000 0 0 +00} + {231292800 3600 1 +00} + {244249200 0 0 +00} + {265507200 3600 1 +00} + {271033200 0 0 +00} + {1212278400 3600 1 +00} + {1220223600 0 0 +00} + {1243814400 3600 1 +00} + {1250809200 0 0 +00} + {1272758400 3600 1 +00} + {1281222000 0 0 +00} + {1301788800 3600 1 +00} + {1312066800 0 0 +00} + {1335664800 3600 1 +00} + {1342749600 0 0 +00} + {1345428000 3600 1 +00} + {1348970400 0 0 +00} + {1367114400 3600 1 +00} + {1373162400 0 0 +00} + {1376100000 3600 1 +00} + {1382839200 0 0 +00} + {1396144800 3600 1 +00} + {1403920800 0 0 +00} + {1406944800 3600 1 +00} + {1414288800 0 0 +00} + {1427594400 3600 1 +00} + {1434247200 0 0 +00} + {1437271200 3600 1 +00} + {1445738400 0 0 +00} + {1459044000 3600 1 +00} + {1465092000 0 0 +00} + {1468116000 3600 1 +00} + {1477792800 0 0 +00} + {1490493600 3600 1 +00} + {1495332000 0 0 +00} + {1498960800 3600 1 +00} + {1509242400 0 0 +00} + {1521943200 3600 1 +00} + {1526176800 0 0 +00} + {1529200800 3600 1 +00} + {1540598400 3600 0 +01} } diff --git a/library/tzdata/Pacific/Honolulu b/library/tzdata/Pacific/Honolulu index 5e70598..7d03b45 100644 --- a/library/tzdata/Pacific/Honolulu +++ b/library/tzdata/Pacific/Honolulu @@ -4,8 +4,9 @@ set TZData(:Pacific/Honolulu) { {-9223372036854775808 -37886 0 LMT} {-2334101314 -37800 0 HST} {-1157283000 -34200 1 HDT} - {-1155436200 -37800 0 HST} - {-880198200 -34200 1 HDT} + {-1155436200 -34200 0 HST} + {-880201800 -34200 1 HWT} + {-769395600 -34200 1 HPT} {-765376200 -37800 0 HST} {-712150200 -36000 0 HST} } -- cgit v0.12 From fbc8feeb407fc9f2ddbf11fa089e56184952581f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 27 Oct 2018 19:33:40 +0000 Subject: Backport various minor issues from 8.6: - gcc compiler warning in tclDate.c - protect Tcl_UtfToUniCharDString() from ever reading more than "length" bytes from its input, not even in the case of invalid UTF-8. - update to latest tzdata - fix 2 failing test-cases on MacOSX --- generic/tclDate.c | 2 +- generic/tclUtf.c | 18 ++- library/tzdata/Africa/Casablanca | 280 ++++++++------------------------------- library/tzdata/Africa/El_Aaiun | 256 ++++++----------------------------- library/tzdata/Pacific/Honolulu | 5 +- tests/macOSXFCmd.test | 22 +-- 6 files changed, 127 insertions(+), 456 deletions(-) diff --git a/generic/tclDate.c b/generic/tclDate.c index 1adcf1e..2cf20d6 100644 --- a/generic/tclDate.c +++ b/generic/tclDate.c @@ -1348,7 +1348,7 @@ yyparse (info) int yychar; /* The semantic value of the look-ahead symbol. */ -YYSTYPE yylval; +YYSTYPE yylval = {0}; /* Number of syntax errors so far. */ int yynerrs; diff --git a/generic/tclUtf.c b/generic/tclUtf.c index 656a6f0..1ef35a6 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -426,18 +426,28 @@ Tcl_UtfToUniCharDString( oldLength = Tcl_DStringLength(dsPtr); Tcl_DStringSetLength(dsPtr, - (int) ((oldLength + length + 1) * sizeof(Tcl_UniChar))); + oldLength + (int) ((length + 1) * sizeof(Tcl_UniChar))); wString = (Tcl_UniChar *) (Tcl_DStringValue(dsPtr) + oldLength); w = wString; - end = src + length; - for (p = src; p < end; ) { + p = src; + end = src + length - TCL_UTF_MAX; + while (p < end) { p += TclUtfToUniChar(p, w); w++; } + end += TCL_UTF_MAX; + while (p < end) { + if (Tcl_UtfCharComplete(p, end-p)) { + p += TclUtfToUniChar(p, w); + } else { + *w = UCHAR(*p++); + } + w++; + } *w = '\0'; Tcl_DStringSetLength(dsPtr, - (oldLength + ((char *) w - (char *) wString))); + oldLength + ((char *) w - (char *) wString)); return wString; } diff --git a/library/tzdata/Africa/Casablanca b/library/tzdata/Africa/Casablanca index 33ad99b..3207e59 100644 --- a/library/tzdata/Africa/Casablanca +++ b/library/tzdata/Africa/Casablanca @@ -2,229 +2,59 @@ set TZData(:Africa/Casablanca) { {-9223372036854775808 -1820 0 LMT} - {-1773012580 0 0 WET} - {-956361600 3600 1 WEST} - {-950490000 0 0 WET} - {-942019200 3600 1 WEST} - {-761187600 0 0 WET} - {-617241600 3600 1 WEST} - {-605149200 0 0 WET} - {-81432000 3600 1 WEST} - {-71110800 0 0 WET} - {141264000 3600 1 WEST} - {147222000 0 0 WET} - {199756800 3600 1 WEST} - {207702000 0 0 WET} - {231292800 3600 1 WEST} - {244249200 0 0 WET} - {265507200 3600 1 WEST} - {271033200 0 0 WET} - {448243200 3600 0 CET} - {504918000 0 0 WET} - {1212278400 3600 1 WEST} - {1220223600 0 0 WET} - {1243814400 3600 1 WEST} - {1250809200 0 0 WET} - {1272758400 3600 1 WEST} - {1281222000 0 0 WET} - {1301788800 3600 1 WEST} - {1312066800 0 0 WET} - {1335664800 3600 1 WEST} - {1342749600 0 0 WET} - {1345428000 3600 1 WEST} - {1348970400 0 0 WET} - {1367114400 3600 1 WEST} - {1373162400 0 0 WET} - {1376100000 3600 1 WEST} - {1382839200 0 0 WET} - {1396144800 3600 1 WEST} - {1403920800 0 0 WET} - {1406944800 3600 1 WEST} - {1414288800 0 0 WET} - {1427594400 3600 1 WEST} - {1434247200 0 0 WET} - {1437271200 3600 1 WEST} - {1445738400 0 0 WET} - {1459044000 3600 1 WEST} - {1465092000 0 0 WET} - {1468116000 3600 1 WEST} - {1477792800 0 0 WET} - {1490493600 3600 1 WEST} - {1495332000 0 0 WET} - {1498960800 3600 1 WEST} - {1509242400 0 0 WET} - {1521943200 3600 1 WEST} - {1526176800 0 0 WET} - {1529200800 3600 1 WEST} - {1540692000 0 0 WET} - {1553997600 3600 1 WEST} - {1557021600 0 0 WET} - {1560045600 3600 1 WEST} - {1572141600 0 0 WET} - {1585447200 3600 1 WEST} - {1587261600 0 0 WET} - {1590285600 3600 1 WEST} - {1603591200 0 0 WET} - {1616896800 3600 1 WEST} - {1618106400 0 0 WET} - {1621130400 3600 1 WEST} - {1635645600 0 0 WET} - {1651975200 3600 1 WEST} - {1667095200 0 0 WET} - {1682215200 3600 1 WEST} - {1698544800 0 0 WET} - {1713060000 3600 1 WEST} - {1729994400 0 0 WET} - {1743904800 3600 1 WEST} - {1761444000 0 0 WET} - {1774749600 3600 1 WEST} - {1792893600 0 0 WET} - {1806199200 3600 1 WEST} - {1824948000 0 0 WET} - {1837648800 3600 1 WEST} - {1856397600 0 0 WET} - {1869098400 3600 1 WEST} - {1887847200 0 0 WET} - {1901152800 3600 1 WEST} - {1919296800 0 0 WET} - {1932602400 3600 1 WEST} - {1950746400 0 0 WET} - {1964052000 3600 1 WEST} - {1982800800 0 0 WET} - {1995501600 3600 1 WEST} - {2014250400 0 0 WET} - {2026951200 3600 1 WEST} - {2045700000 0 0 WET} - {2058400800 3600 1 WEST} - {2077149600 0 0 WET} - {2090455200 3600 1 WEST} - {2107994400 0 0 WET} - {2108602800 0 0 WET} - {2121904800 3600 1 WEST} - {2138234400 0 0 WET} - {2140052400 0 0 WET} - {2153354400 3600 1 WEST} - {2172103200 0 0 WET} - {2184804000 3600 1 WEST} - {2203552800 0 0 WET} - {2216253600 3600 1 WEST} - {2235002400 0 0 WET} - {2248308000 3600 1 WEST} - {2266452000 0 0 WET} - {2279757600 3600 1 WEST} - {2297901600 0 0 WET} - {2311207200 3600 1 WEST} - {2329351200 0 0 WET} - {2342656800 3600 1 WEST} - {2361405600 0 0 WET} - {2374106400 3600 1 WEST} - {2392855200 0 0 WET} - {2405556000 3600 1 WEST} - {2424304800 0 0 WET} - {2437610400 3600 1 WEST} - {2455754400 0 0 WET} - {2469060000 3600 1 WEST} - {2487204000 0 0 WET} - {2500509600 3600 1 WEST} - {2519258400 0 0 WET} - {2531959200 3600 1 WEST} - {2550708000 0 0 WET} - {2563408800 3600 1 WEST} - {2582157600 0 0 WET} - {2595463200 3600 1 WEST} - {2613607200 0 0 WET} - {2626912800 3600 1 WEST} - {2645056800 0 0 WET} - {2658362400 3600 1 WEST} - {2676506400 0 0 WET} - {2689812000 3600 1 WEST} - {2708560800 0 0 WET} - {2721261600 3600 1 WEST} - {2740010400 0 0 WET} - {2752711200 3600 1 WEST} - {2771460000 0 0 WET} - {2784765600 3600 1 WEST} - {2802909600 0 0 WET} - {2816215200 3600 1 WEST} - {2834359200 0 0 WET} - {2847664800 3600 1 WEST} - {2866413600 0 0 WET} - {2879114400 3600 1 WEST} - {2897863200 0 0 WET} - {2910564000 3600 1 WEST} - {2929312800 0 0 WET} - {2942013600 3600 1 WEST} - {2960762400 0 0 WET} - {2974068000 3600 1 WEST} - {2992212000 0 0 WET} - {3005517600 3600 1 WEST} - {3023661600 0 0 WET} - {3036967200 3600 1 WEST} - {3055716000 0 0 WET} - {3068416800 3600 1 WEST} - {3087165600 0 0 WET} - {3099866400 3600 1 WEST} - {3118615200 0 0 WET} - {3131920800 3600 1 WEST} - {3150064800 0 0 WET} - {3163370400 3600 1 WEST} - {3181514400 0 0 WET} - {3194820000 3600 1 WEST} - {3212964000 0 0 WET} - {3226269600 3600 1 WEST} - {3245018400 0 0 WET} - {3257719200 3600 1 WEST} - {3276468000 0 0 WET} - {3289168800 3600 1 WEST} - {3307917600 0 0 WET} - {3321223200 3600 1 WEST} - {3339367200 0 0 WET} - {3352672800 3600 1 WEST} - {3370816800 0 0 WET} - {3384122400 3600 1 WEST} - {3402871200 0 0 WET} - {3415572000 3600 1 WEST} - {3434320800 0 0 WET} - {3447021600 3600 1 WEST} - {3465770400 0 0 WET} - {3479076000 3600 1 WEST} - {3497220000 0 0 WET} - {3510525600 3600 1 WEST} - {3528669600 0 0 WET} - {3541975200 3600 1 WEST} - {3560119200 0 0 WET} - {3573424800 3600 1 WEST} - {3592173600 0 0 WET} - {3604874400 3600 1 WEST} - {3623623200 0 0 WET} - {3636324000 3600 1 WEST} - {3655072800 0 0 WET} - {3668378400 3600 1 WEST} - {3686522400 0 0 WET} - {3699828000 3600 1 WEST} - {3717972000 0 0 WET} - {3731277600 3600 1 WEST} - {3750026400 0 0 WET} - {3762727200 3600 1 WEST} - {3781476000 0 0 WET} - {3794176800 3600 1 WEST} - {3812925600 0 0 WET} - {3825626400 3600 1 WEST} - {3844375200 0 0 WET} - {3857680800 3600 1 WEST} - {3875824800 0 0 WET} - {3889130400 3600 1 WEST} - {3907274400 0 0 WET} - {3920580000 3600 1 WEST} - {3939328800 0 0 WET} - {3952029600 3600 1 WEST} - {3970778400 0 0 WET} - {3983479200 3600 1 WEST} - {4002228000 0 0 WET} - {4015533600 3600 1 WEST} - {4033677600 0 0 WET} - {4046983200 3600 1 WEST} - {4065127200 0 0 WET} - {4078432800 3600 1 WEST} - {4096576800 0 0 WET} + {-1773012580 0 0 +00} + {-956361600 3600 1 +00} + {-950490000 0 0 +00} + {-942019200 3600 1 +00} + {-761187600 0 0 +00} + {-617241600 3600 1 +00} + {-605149200 0 0 +00} + {-81432000 3600 1 +00} + {-71110800 0 0 +00} + {141264000 3600 1 +00} + {147222000 0 0 +00} + {199756800 3600 1 +00} + {207702000 0 0 +00} + {231292800 3600 1 +00} + {244249200 0 0 +00} + {265507200 3600 1 +00} + {271033200 0 0 +00} + {448243200 3600 0 +01} + {504918000 0 0 +00} + {1212278400 3600 1 +00} + {1220223600 0 0 +00} + {1243814400 3600 1 +00} + {1250809200 0 0 +00} + {1272758400 3600 1 +00} + {1281222000 0 0 +00} + {1301788800 3600 1 +00} + {1312066800 0 0 +00} + {1335664800 3600 1 +00} + {1342749600 0 0 +00} + {1345428000 3600 1 +00} + {1348970400 0 0 +00} + {1367114400 3600 1 +00} + {1373162400 0 0 +00} + {1376100000 3600 1 +00} + {1382839200 0 0 +00} + {1396144800 3600 1 +00} + {1403920800 0 0 +00} + {1406944800 3600 1 +00} + {1414288800 0 0 +00} + {1427594400 3600 1 +00} + {1434247200 0 0 +00} + {1437271200 3600 1 +00} + {1445738400 0 0 +00} + {1459044000 3600 1 +00} + {1465092000 0 0 +00} + {1468116000 3600 1 +00} + {1477792800 0 0 +00} + {1490493600 3600 1 +00} + {1495332000 0 0 +00} + {1498960800 3600 1 +00} + {1509242400 0 0 +00} + {1521943200 3600 1 +00} + {1526176800 0 0 +00} + {1529200800 3600 1 +00} + {1540598400 3600 0 +01} } diff --git a/library/tzdata/Africa/El_Aaiun b/library/tzdata/Africa/El_Aaiun index 7bdc496..e0f5e1c 100644 --- a/library/tzdata/Africa/El_Aaiun +++ b/library/tzdata/Africa/El_Aaiun @@ -3,217 +3,47 @@ set TZData(:Africa/El_Aaiun) { {-9223372036854775808 -3168 0 LMT} {-1136070432 -3600 0 -01} - {198291600 0 0 WET} - {199756800 3600 1 WEST} - {207702000 0 0 WET} - {231292800 3600 1 WEST} - {244249200 0 0 WET} - {265507200 3600 1 WEST} - {271033200 0 0 WET} - {1212278400 3600 1 WEST} - {1220223600 0 0 WET} - {1243814400 3600 1 WEST} - {1250809200 0 0 WET} - {1272758400 3600 1 WEST} - {1281222000 0 0 WET} - {1301788800 3600 1 WEST} - {1312066800 0 0 WET} - {1335664800 3600 1 WEST} - {1342749600 0 0 WET} - {1345428000 3600 1 WEST} - {1348970400 0 0 WET} - {1367114400 3600 1 WEST} - {1373162400 0 0 WET} - {1376100000 3600 1 WEST} - {1382839200 0 0 WET} - {1396144800 3600 1 WEST} - {1403920800 0 0 WET} - {1406944800 3600 1 WEST} - {1414288800 0 0 WET} - {1427594400 3600 1 WEST} - {1434247200 0 0 WET} - {1437271200 3600 1 WEST} - {1445738400 0 0 WET} - {1459044000 3600 1 WEST} - {1465092000 0 0 WET} - {1468116000 3600 1 WEST} - {1477792800 0 0 WET} - {1490493600 3600 1 WEST} - {1495332000 0 0 WET} - {1498960800 3600 1 WEST} - {1509242400 0 0 WET} - {1521943200 3600 1 WEST} - {1526176800 0 0 WET} - {1529200800 3600 1 WEST} - {1540692000 0 0 WET} - {1553997600 3600 1 WEST} - {1557021600 0 0 WET} - {1560045600 3600 1 WEST} - {1572141600 0 0 WET} - {1585447200 3600 1 WEST} - {1587261600 0 0 WET} - {1590285600 3600 1 WEST} - {1603591200 0 0 WET} - {1616896800 3600 1 WEST} - {1618106400 0 0 WET} - {1621130400 3600 1 WEST} - {1635645600 0 0 WET} - {1651975200 3600 1 WEST} - {1667095200 0 0 WET} - {1682215200 3600 1 WEST} - {1698544800 0 0 WET} - {1713060000 3600 1 WEST} - {1729994400 0 0 WET} - {1743904800 3600 1 WEST} - {1761444000 0 0 WET} - {1774749600 3600 1 WEST} - {1792893600 0 0 WET} - {1806199200 3600 1 WEST} - {1824948000 0 0 WET} - {1837648800 3600 1 WEST} - {1856397600 0 0 WET} - {1869098400 3600 1 WEST} - {1887847200 0 0 WET} - {1901152800 3600 1 WEST} - {1919296800 0 0 WET} - {1932602400 3600 1 WEST} - {1950746400 0 0 WET} - {1964052000 3600 1 WEST} - {1982800800 0 0 WET} - {1995501600 3600 1 WEST} - {2014250400 0 0 WET} - {2026951200 3600 1 WEST} - {2045700000 0 0 WET} - {2058400800 3600 1 WEST} - {2077149600 0 0 WET} - {2090455200 3600 1 WEST} - {2107994400 0 0 WET} - {2108602800 0 0 WET} - {2121904800 3600 1 WEST} - {2138234400 0 0 WET} - {2140052400 0 0 WET} - {2153354400 3600 1 WEST} - {2172103200 0 0 WET} - {2184804000 3600 1 WEST} - {2203552800 0 0 WET} - {2216253600 3600 1 WEST} - {2235002400 0 0 WET} - {2248308000 3600 1 WEST} - {2266452000 0 0 WET} - {2279757600 3600 1 WEST} - {2297901600 0 0 WET} - {2311207200 3600 1 WEST} - {2329351200 0 0 WET} - {2342656800 3600 1 WEST} - {2361405600 0 0 WET} - {2374106400 3600 1 WEST} - {2392855200 0 0 WET} - {2405556000 3600 1 WEST} - {2424304800 0 0 WET} - {2437610400 3600 1 WEST} - {2455754400 0 0 WET} - {2469060000 3600 1 WEST} - {2487204000 0 0 WET} - {2500509600 3600 1 WEST} - {2519258400 0 0 WET} - {2531959200 3600 1 WEST} - {2550708000 0 0 WET} - {2563408800 3600 1 WEST} - {2582157600 0 0 WET} - {2595463200 3600 1 WEST} - {2613607200 0 0 WET} - {2626912800 3600 1 WEST} - {2645056800 0 0 WET} - {2658362400 3600 1 WEST} - {2676506400 0 0 WET} - {2689812000 3600 1 WEST} - {2708560800 0 0 WET} - {2721261600 3600 1 WEST} - {2740010400 0 0 WET} - {2752711200 3600 1 WEST} - {2771460000 0 0 WET} - {2784765600 3600 1 WEST} - {2802909600 0 0 WET} - {2816215200 3600 1 WEST} - {2834359200 0 0 WET} - {2847664800 3600 1 WEST} - {2866413600 0 0 WET} - {2879114400 3600 1 WEST} - {2897863200 0 0 WET} - {2910564000 3600 1 WEST} - {2929312800 0 0 WET} - {2942013600 3600 1 WEST} - {2960762400 0 0 WET} - {2974068000 3600 1 WEST} - {2992212000 0 0 WET} - {3005517600 3600 1 WEST} - {3023661600 0 0 WET} - {3036967200 3600 1 WEST} - {3055716000 0 0 WET} - {3068416800 3600 1 WEST} - {3087165600 0 0 WET} - {3099866400 3600 1 WEST} - {3118615200 0 0 WET} - {3131920800 3600 1 WEST} - {3150064800 0 0 WET} - {3163370400 3600 1 WEST} - {3181514400 0 0 WET} - {3194820000 3600 1 WEST} - {3212964000 0 0 WET} - {3226269600 3600 1 WEST} - {3245018400 0 0 WET} - {3257719200 3600 1 WEST} - {3276468000 0 0 WET} - {3289168800 3600 1 WEST} - {3307917600 0 0 WET} - {3321223200 3600 1 WEST} - {3339367200 0 0 WET} - {3352672800 3600 1 WEST} - {3370816800 0 0 WET} - {3384122400 3600 1 WEST} - {3402871200 0 0 WET} - {3415572000 3600 1 WEST} - {3434320800 0 0 WET} - {3447021600 3600 1 WEST} - {3465770400 0 0 WET} - {3479076000 3600 1 WEST} - {3497220000 0 0 WET} - {3510525600 3600 1 WEST} - {3528669600 0 0 WET} - {3541975200 3600 1 WEST} - {3560119200 0 0 WET} - {3573424800 3600 1 WEST} - {3592173600 0 0 WET} - {3604874400 3600 1 WEST} - {3623623200 0 0 WET} - {3636324000 3600 1 WEST} - {3655072800 0 0 WET} - {3668378400 3600 1 WEST} - {3686522400 0 0 WET} - {3699828000 3600 1 WEST} - {3717972000 0 0 WET} - {3731277600 3600 1 WEST} - {3750026400 0 0 WET} - {3762727200 3600 1 WEST} - {3781476000 0 0 WET} - {3794176800 3600 1 WEST} - {3812925600 0 0 WET} - {3825626400 3600 1 WEST} - {3844375200 0 0 WET} - {3857680800 3600 1 WEST} - {3875824800 0 0 WET} - {3889130400 3600 1 WEST} - {3907274400 0 0 WET} - {3920580000 3600 1 WEST} - {3939328800 0 0 WET} - {3952029600 3600 1 WEST} - {3970778400 0 0 WET} - {3983479200 3600 1 WEST} - {4002228000 0 0 WET} - {4015533600 3600 1 WEST} - {4033677600 0 0 WET} - {4046983200 3600 1 WEST} - {4065127200 0 0 WET} - {4078432800 3600 1 WEST} - {4096576800 0 0 WET} + {198291600 0 0 +00} + {199756800 3600 1 +00} + {207702000 0 0 +00} + {231292800 3600 1 +00} + {244249200 0 0 +00} + {265507200 3600 1 +00} + {271033200 0 0 +00} + {1212278400 3600 1 +00} + {1220223600 0 0 +00} + {1243814400 3600 1 +00} + {1250809200 0 0 +00} + {1272758400 3600 1 +00} + {1281222000 0 0 +00} + {1301788800 3600 1 +00} + {1312066800 0 0 +00} + {1335664800 3600 1 +00} + {1342749600 0 0 +00} + {1345428000 3600 1 +00} + {1348970400 0 0 +00} + {1367114400 3600 1 +00} + {1373162400 0 0 +00} + {1376100000 3600 1 +00} + {1382839200 0 0 +00} + {1396144800 3600 1 +00} + {1403920800 0 0 +00} + {1406944800 3600 1 +00} + {1414288800 0 0 +00} + {1427594400 3600 1 +00} + {1434247200 0 0 +00} + {1437271200 3600 1 +00} + {1445738400 0 0 +00} + {1459044000 3600 1 +00} + {1465092000 0 0 +00} + {1468116000 3600 1 +00} + {1477792800 0 0 +00} + {1490493600 3600 1 +00} + {1495332000 0 0 +00} + {1498960800 3600 1 +00} + {1509242400 0 0 +00} + {1521943200 3600 1 +00} + {1526176800 0 0 +00} + {1529200800 3600 1 +00} + {1540598400 3600 0 +01} } diff --git a/library/tzdata/Pacific/Honolulu b/library/tzdata/Pacific/Honolulu index 5e70598..7d03b45 100644 --- a/library/tzdata/Pacific/Honolulu +++ b/library/tzdata/Pacific/Honolulu @@ -4,8 +4,9 @@ set TZData(:Pacific/Honolulu) { {-9223372036854775808 -37886 0 LMT} {-2334101314 -37800 0 HST} {-1157283000 -34200 1 HDT} - {-1155436200 -37800 0 HST} - {-880198200 -34200 1 HDT} + {-1155436200 -34200 0 HST} + {-880201800 -34200 1 HWT} + {-769395600 -34200 1 HPT} {-765376200 -37800 0 HST} {-712150200 -36000 0 HST} } diff --git a/tests/macOSXFCmd.test b/tests/macOSXFCmd.test index 071f11b..f1758f5 100644 --- a/tests/macOSXFCmd.test +++ b/tests/macOSXFCmd.test @@ -99,7 +99,7 @@ test macOSXFCmd-2.6 {MacOSXSetFileAttribute - hidden} {macosxFileAttr notRoot} { [catch {file attributes foo.test -hidden} msg] $msg \ [file delete -force -- foo.test] } {0 {} 0 1 {}} -test macOSXFCmd-2.7 {MacOSXSetFileAttribute - rsrclength} {macosxFileAttr notRoot} { +test macOSXFCmd-2.7 {MacOSXSetFileAttribute - rsrclength} {macosxFileAttr notRoot nonPortable} { catch {file delete -force -- foo.test} close [open foo.test w] catch { @@ -151,16 +151,16 @@ test macOSXFCmd-4.1 {TclMacOSXMatchType} {macosxFileAttr notRoot} { file attributes dir.test -hidden 1 } set res [list \ - [catch {glob *.test} msg] $msg \ - [catch {glob -types FOOT *.test} msg] $msg \ - [catch {glob -types {{macintosh type FOOT}} *.test} msg] $msg \ - [catch {glob -types FOOTT *.test} msg] $msg \ - [catch {glob -types {{macintosh type FOOTT}} *.test} msg] $msg \ - [catch {glob -types {{macintosh type {}}} *.test} msg] $msg \ - [catch {glob -types {{macintosh creator FOOC}} *.test} msg] $msg \ - [catch {glob -types {{macintosh creator FOOC} {macintosh type FOOT}} *.test} msg] $msg \ - [catch {glob -types hidden *.test} msg] $msg \ - [catch {glob -types {hidden FOOT} *.test} msg] $msg \ + [catch {lsort [glob *.test]} msg] $msg \ + [catch {lsort [glob -types FOOT *.test]} msg] $msg \ + [catch {lsort [glob -types {{macintosh type FOOT}} *.test]} msg] $msg \ + [catch {lsort [glob -types FOOTT *.test]} msg] $msg \ + [catch {lsort [glob -types {{macintosh type FOOTT}} *.test]} msg] $msg \ + [catch {lsort [glob -types {{macintosh type {}}} *.test]} msg] $msg \ + [catch {lsort [glob -types {{macintosh creator FOOC}} *.test]} msg] $msg \ + [catch {lsort [glob -types {{macintosh creator FOOC} {macintosh type FOOT}} *.test]} msg] $msg \ + [catch {lsort [glob -types hidden *.test]} msg] $msg \ + [catch {lsort [glob -types {hidden FOOT} *.test]} msg] $msg \ ] cd .. file delete -force globtest -- cgit v0.12 From 97ed5b117d97994ac272d663a4c754ab73afeace Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 27 Oct 2018 19:36:22 +0000 Subject: (temporary) backout [0386db909a]: Enable CI builds with Travis. This enables everything else to merge-marked to 8.6. Will put it back in the next commit --- README | 185 ++++++++++++++++++++++++++++++++++++++++++++ library/tcltest/tcltest.tcl | 4 +- tests/all.tcl | 4 +- 3 files changed, 188 insertions(+), 5 deletions(-) create mode 100644 README diff --git a/README b/README new file mode 100644 index 0000000..c71d177 --- /dev/null +++ b/README @@ -0,0 +1,185 @@ +README: Tcl + This is the Tcl 8.5.19 source distribution. + http://sourceforge.net/projects/tcl/files/Tcl/ + You can get any source release of Tcl from the URL above. + +Contents +-------- + 1. Introduction + 2. Documentation + 3. Compiling and installing Tcl + 4. Development tools + 5. Tcl newsgroup + 6. The Tcler's Wiki + 7. Mailing lists + 8. Support and Training + 9. Tracking Development + 10. Thank You + +1. Introduction +--------------- +Tcl provides a powerful platform for creating integration applications that +tie together diverse applications, protocols, devices, and frameworks. +When paired with the Tk toolkit, Tcl provides the fastest and most powerful +way to create GUI applications that run on PCs, Unix, and Mac OS X. +Tcl can also be used for a variety of web-related tasks and for creating +powerful command languages for applications. + +Tcl is maintained, enhanced, and distributed freely by the Tcl community. +Source code development and tracking of bug reports and feature requests +takes place at: + + http://core.tcl.tk/ + +Tcl/Tk release and mailing list services are hosted by SourceForge: + + http://sourceforge.net/projects/tcl/ + +with the Tcl Developer Xchange hosted at: + + http://www.tcl.tk/ + +Tcl is a freely available open source package. You can do virtually +anything you like with it, such as modifying it, redistributing it, +and selling it either in whole or in part. See the file +"license.terms" for complete information. + +2. Documentation +---------------- + +Extensive documentation is available at our website. +The home page for this release, including new features, is + http://www.tcl.tk/software/tcltk/8.5.html + +Detailed release notes can be found at the file distributions page +by clicking on the relevant version. + http://sourceforge.net/projects/tcl/files/Tcl/ + +Information about Tcl itself can be found at + http://www.tcl.tk/about/ + +There have been many Tcl books on the market. Many are mentioned in the Wiki: + http://wiki.tcl.tk/_/ref?N=25206 + +To view the complete set of reference manual entries for Tcl 8.5 online, +visit the URL: + http://www.tcl.tk/man/tcl8.5/ + +2a. Unix Documentation +---------------------- + +The "doc" subdirectory in this release contains a complete set of +reference manual entries for Tcl. Files with extension ".1" are for +programs (for example, tclsh.1); files with extension ".3" are for C +library procedures; and files with extension ".n" describe Tcl +commands. The file "doc/Tcl.n" gives a quick summary of the Tcl +language syntax. To print any of the man pages on Unix, cd to the +"doc" directory and invoke your favorite variant of troff using the +normal -man macros, for example + + ditroff -man Tcl.n + +to print Tcl.n. If Tcl has been installed correctly and your "man" program +supports it, you should be able to access the Tcl manual entries using the +normal "man" mechanisms, such as + + man Tcl + +2b. Windows Documentation +------------------------- + +The "doc" subdirectory in this release contains a complete set of Windows +help files for Tcl. Once you install this Tcl release, a shortcut to the +Windows help Tcl documentation will appear in the "Start" menu: + + Start | Programs | Tcl | Tcl Help + +3. Compiling and installing Tcl +------------------------------- + +There are brief notes in the unix/README, win/README, and macosx/README about +compiling on these different platforms. There is additional information +about building Tcl from sources at + + http://www.tcl.tk/doc/howto/compile.html + +4. Development tools +--------------------------- + +ActiveState produces a high quality set of commercial quality development +tools that is available to accelerate your Tcl application development. +Tcl Dev Kit builds on the earlier TclPro toolset and provides a debugger, +static code checker, single-file wrapping utility, bytecode compiler and +more. More information can be found at + + http://www.ActiveState.com/Tcl + +5. Tcl newsgroup +---------------- + +There is a USENET news group, "comp.lang.tcl", intended for the exchange of +information about Tcl, Tk, and related applications. The newsgroup is a +great place to ask general information questions. For bug reports, please +see the "Support and bug fixes" section below. + +6. Tcl'ers Wiki +--------------- + +A Wiki-based open community site covering all aspects of Tcl/Tk is at: + + http://wiki.tcl.tk/ + +It is dedicated to the Tcl programming language and its extensions. A +wealth of useful information can be found there. It contains code +snippets, references to papers, books, and FAQs, as well as pointers to +development tools, extensions, and applications. You can also recommend +additional URLs by editing the wiki yourself. + +7. Mailing lists +---------------- + +Several mailing lists are hosted at SourceForge to discuss development or +use issues (like Macintosh and Windows topics). For more information and +to subscribe, visit: + + http://sourceforge.net/projects/tcl/ + +and go to the Mailing Lists page. + +8. Support and Training +------------------------ + +We are very interested in receiving bug reports, patches, and suggestions +for improvements. We prefer that you send this information to us as +tickets entered into our tracker at: + + http://core.tcl.tk/tcl/reportlist + +We will log and follow-up on each bug, although we cannot promise a +specific turn-around time. Enhancements may take longer and may not happen +at all unless there is widespread support for them (we're trying to +slow the rate at which Tcl/Tk turns into a kitchen sink). It's very +difficult to make incompatible changes to Tcl/Tk at this point, due to +the size of the installed base. + +The Tcl community is too large for us to provide much individual support +for users. If you need help we suggest that you post questions to +comp.lang.tcl. We read the newsgroup and will attempt to answer esoteric +questions for which no one else is likely to know the answer. In addition, +see the following Web site for links to other organizations that offer +Tcl/Tk training: + + http://wiki.tcl.tk/training + +9. Tracking Development +----------------------- + +Tcl is developed in public. To keep an eye on how Tcl is changing, see + http://core.tcl.tk/ + +10. Thank You +------------- + +We'd like to express our thanks to the Tcl community for all the +helpful suggestions, bug reports, and patches we have received. +Tcl/Tk has improved vastly and will continue to do so with your help. diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index f69ffd2..936acaa 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -2700,7 +2700,7 @@ proc tcltest::GetMatchingDirectories {rootdir} { # shell being tested # # Results: -# Whether there were any failures. +# None. # # Side effects: # None. @@ -2846,7 +2846,7 @@ proc tcltest::runAllTests { {shell ""} } { puts [outputChannel] "" puts [outputChannel] [string repeat ~ 44] } - return [info exists testFileFailures] + return } ##################################################################### diff --git a/tests/all.tcl b/tests/all.tcl index f3463c6..d01a54d 100644 --- a/tests/all.tcl +++ b/tests/all.tcl @@ -14,6 +14,4 @@ package require Tcl 8.5 package require tcltest 2.2 namespace import tcltest::* configure {*}$argv -testdir [file dir [info script]] -set ErrorOnFailures [info exists env(ERROR_ON_FAILURES)] -unset -nocomplain env(ERROR_ON_FAILURES) -if {[runAllTests] && $ErrorOnFailures} {exit 1} +runAllTests -- cgit v0.12 From 52c009322f08d5c54ee93e67f439d8e06399a3a1 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 27 Oct 2018 19:52:25 +0000 Subject: put back Travis CI build. All merge-marks of previous commit change done. --- README | 185 -------------------------------------------- library/tcltest/tcltest.tcl | 4 +- tests/all.tcl | 4 +- 3 files changed, 5 insertions(+), 188 deletions(-) delete mode 100644 README diff --git a/README b/README deleted file mode 100644 index c71d177..0000000 --- a/README +++ /dev/null @@ -1,185 +0,0 @@ -README: Tcl - This is the Tcl 8.5.19 source distribution. - http://sourceforge.net/projects/tcl/files/Tcl/ - You can get any source release of Tcl from the URL above. - -Contents --------- - 1. Introduction - 2. Documentation - 3. Compiling and installing Tcl - 4. Development tools - 5. Tcl newsgroup - 6. The Tcler's Wiki - 7. Mailing lists - 8. Support and Training - 9. Tracking Development - 10. Thank You - -1. Introduction ---------------- -Tcl provides a powerful platform for creating integration applications that -tie together diverse applications, protocols, devices, and frameworks. -When paired with the Tk toolkit, Tcl provides the fastest and most powerful -way to create GUI applications that run on PCs, Unix, and Mac OS X. -Tcl can also be used for a variety of web-related tasks and for creating -powerful command languages for applications. - -Tcl is maintained, enhanced, and distributed freely by the Tcl community. -Source code development and tracking of bug reports and feature requests -takes place at: - - http://core.tcl.tk/ - -Tcl/Tk release and mailing list services are hosted by SourceForge: - - http://sourceforge.net/projects/tcl/ - -with the Tcl Developer Xchange hosted at: - - http://www.tcl.tk/ - -Tcl is a freely available open source package. You can do virtually -anything you like with it, such as modifying it, redistributing it, -and selling it either in whole or in part. See the file -"license.terms" for complete information. - -2. Documentation ----------------- - -Extensive documentation is available at our website. -The home page for this release, including new features, is - http://www.tcl.tk/software/tcltk/8.5.html - -Detailed release notes can be found at the file distributions page -by clicking on the relevant version. - http://sourceforge.net/projects/tcl/files/Tcl/ - -Information about Tcl itself can be found at - http://www.tcl.tk/about/ - -There have been many Tcl books on the market. Many are mentioned in the Wiki: - http://wiki.tcl.tk/_/ref?N=25206 - -To view the complete set of reference manual entries for Tcl 8.5 online, -visit the URL: - http://www.tcl.tk/man/tcl8.5/ - -2a. Unix Documentation ----------------------- - -The "doc" subdirectory in this release contains a complete set of -reference manual entries for Tcl. Files with extension ".1" are for -programs (for example, tclsh.1); files with extension ".3" are for C -library procedures; and files with extension ".n" describe Tcl -commands. The file "doc/Tcl.n" gives a quick summary of the Tcl -language syntax. To print any of the man pages on Unix, cd to the -"doc" directory and invoke your favorite variant of troff using the -normal -man macros, for example - - ditroff -man Tcl.n - -to print Tcl.n. If Tcl has been installed correctly and your "man" program -supports it, you should be able to access the Tcl manual entries using the -normal "man" mechanisms, such as - - man Tcl - -2b. Windows Documentation -------------------------- - -The "doc" subdirectory in this release contains a complete set of Windows -help files for Tcl. Once you install this Tcl release, a shortcut to the -Windows help Tcl documentation will appear in the "Start" menu: - - Start | Programs | Tcl | Tcl Help - -3. Compiling and installing Tcl -------------------------------- - -There are brief notes in the unix/README, win/README, and macosx/README about -compiling on these different platforms. There is additional information -about building Tcl from sources at - - http://www.tcl.tk/doc/howto/compile.html - -4. Development tools ---------------------------- - -ActiveState produces a high quality set of commercial quality development -tools that is available to accelerate your Tcl application development. -Tcl Dev Kit builds on the earlier TclPro toolset and provides a debugger, -static code checker, single-file wrapping utility, bytecode compiler and -more. More information can be found at - - http://www.ActiveState.com/Tcl - -5. Tcl newsgroup ----------------- - -There is a USENET news group, "comp.lang.tcl", intended for the exchange of -information about Tcl, Tk, and related applications. The newsgroup is a -great place to ask general information questions. For bug reports, please -see the "Support and bug fixes" section below. - -6. Tcl'ers Wiki ---------------- - -A Wiki-based open community site covering all aspects of Tcl/Tk is at: - - http://wiki.tcl.tk/ - -It is dedicated to the Tcl programming language and its extensions. A -wealth of useful information can be found there. It contains code -snippets, references to papers, books, and FAQs, as well as pointers to -development tools, extensions, and applications. You can also recommend -additional URLs by editing the wiki yourself. - -7. Mailing lists ----------------- - -Several mailing lists are hosted at SourceForge to discuss development or -use issues (like Macintosh and Windows topics). For more information and -to subscribe, visit: - - http://sourceforge.net/projects/tcl/ - -and go to the Mailing Lists page. - -8. Support and Training ------------------------- - -We are very interested in receiving bug reports, patches, and suggestions -for improvements. We prefer that you send this information to us as -tickets entered into our tracker at: - - http://core.tcl.tk/tcl/reportlist - -We will log and follow-up on each bug, although we cannot promise a -specific turn-around time. Enhancements may take longer and may not happen -at all unless there is widespread support for them (we're trying to -slow the rate at which Tcl/Tk turns into a kitchen sink). It's very -difficult to make incompatible changes to Tcl/Tk at this point, due to -the size of the installed base. - -The Tcl community is too large for us to provide much individual support -for users. If you need help we suggest that you post questions to -comp.lang.tcl. We read the newsgroup and will attempt to answer esoteric -questions for which no one else is likely to know the answer. In addition, -see the following Web site for links to other organizations that offer -Tcl/Tk training: - - http://wiki.tcl.tk/training - -9. Tracking Development ------------------------ - -Tcl is developed in public. To keep an eye on how Tcl is changing, see - http://core.tcl.tk/ - -10. Thank You -------------- - -We'd like to express our thanks to the Tcl community for all the -helpful suggestions, bug reports, and patches we have received. -Tcl/Tk has improved vastly and will continue to do so with your help. diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index 936acaa..f69ffd2 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -2700,7 +2700,7 @@ proc tcltest::GetMatchingDirectories {rootdir} { # shell being tested # # Results: -# None. +# Whether there were any failures. # # Side effects: # None. @@ -2846,7 +2846,7 @@ proc tcltest::runAllTests { {shell ""} } { puts [outputChannel] "" puts [outputChannel] [string repeat ~ 44] } - return + return [info exists testFileFailures] } ##################################################################### diff --git a/tests/all.tcl b/tests/all.tcl index d01a54d..f3463c6 100644 --- a/tests/all.tcl +++ b/tests/all.tcl @@ -14,4 +14,6 @@ package require Tcl 8.5 package require tcltest 2.2 namespace import tcltest::* configure {*}$argv -testdir [file dir [info script]] -runAllTests +set ErrorOnFailures [info exists env(ERROR_ON_FAILURES)] +unset -nocomplain env(ERROR_ON_FAILURES) +if {[runAllTests] && $ErrorOnFailures} {exit 1} -- cgit v0.12 From 3dc41c544f318f7d4ebc0a3f15f2d6b3476ef4a0 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 27 Oct 2018 22:05:34 +0000 Subject: Core machinery for implementing TIP 524; still needs user-facing access commands --- generic/tclOO.c | 34 +++++- generic/tclOOCall.c | 263 ++++++++++++++++++++++++++++++++++++++++++++++ generic/tclOODefineCmds.c | 32 ++++-- generic/tclOOInt.h | 20 ++++ 4 files changed, 335 insertions(+), 14 deletions(-) diff --git a/generic/tclOO.c b/generic/tclOO.c index 2491c2f..1860796 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -456,16 +456,24 @@ InitClassSystemRoots( /* Corresponding TclOODecrRefCount in KillFoudation */ AddRef(fPtr->objectCls->thisPtr); - /* This is why it is unnecessary in this routine to replace the + /* + * This is why it is unnecessary in this routine to replace the * incremented reference count of fPtr->objectCls that was swallowed by - * fakeObject. */ + * fakeObject. + */ + fPtr->objectCls->superclasses.num = 0; ckfree(fPtr->objectCls->superclasses.list); fPtr->objectCls->superclasses.list = NULL; - /* special initialization for the primordial objects */ + /* + * Special initialization for the primordial objects. + */ + fPtr->objectCls->thisPtr->flags |= ROOT_OBJECT; fPtr->objectCls->flags |= ROOT_OBJECT; + TclNewLiteralStringObj(fPtr->objectCls->objDefinitionNs, "::oo::objdefine"); + Tcl_IncrRefCount(fPtr->objectCls->objDefinitionNs); fPtr->classCls = TclOOAllocClass(interp, AllocObject(interp, "class", (Namespace *)fPtr->ooNs, NULL)); @@ -480,7 +488,10 @@ InitClassSystemRoots( * KillFoundation. */ - /* Rewire bootstrapped objects. */ + /* + * Rewire bootstrapped objects. + */ + fPtr->objectCls->thisPtr->selfCls = fPtr->classCls; AddRef(fPtr->classCls->thisPtr); TclOOAddToInstances(fPtr->objectCls->thisPtr, fPtr->classCls); @@ -491,6 +502,8 @@ InitClassSystemRoots( fPtr->classCls->thisPtr->flags |= ROOT_CLASS; fPtr->classCls->flags |= ROOT_CLASS; + TclNewLiteralStringObj(fPtr->objectCls->clsDefinitionNs, "::oo::define"); + Tcl_IncrRefCount(fPtr->objectCls->clsDefinitionNs); /* Standard initialization for new Objects */ TclOOAddToSubclasses(fPtr->classCls, fPtr->objectCls); @@ -959,6 +972,19 @@ TclOOReleaseClassContents( } /* + * Stop using the class for definition information. + */ + + if (clsPtr->clsDefinitionNs) { + Tcl_DecrRefCount(clsPtr->clsDefinitionNs); + clsPtr->clsDefinitionNs = NULL; + } + if (clsPtr->objDefinitionNs) { + Tcl_DecrRefCount(clsPtr->objDefinitionNs); + clsPtr->objDefinitionNs = NULL; + } + + /* * Squelch method implementation chain caches. */ diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c index 9d5312c..39cd1ba 100644 --- a/generic/tclOOCall.c +++ b/generic/tclOOCall.c @@ -31,6 +31,22 @@ struct ChainBuilder { }; /* + * Structures used for traversing the class hierarchy to find out where + * definitions are supposed to be done. + */ + +typedef struct { + Class *definerCls; + Tcl_Obj *namespaceName; +} DefineEntry; + +typedef struct { + DefineEntry *list; + int num; + int size; +} DefineChain; + +/* * Extra flags used for call chain management. */ @@ -77,6 +93,9 @@ static void AddClassFiltersToCallContext(Object *const oPtr, static void AddClassMethodNames(Class *clsPtr, const int flags, Tcl_HashTable *const namesPtr, Tcl_HashTable *const examinedClassesPtr); +static inline void AddDefinitionNamespaceToChain(Class *const definerCls, + Tcl_Obj *const namespaceName, + DefineChain *const definePtr, const int flags); static inline void AddMethodToCallChain(Method *const mPtr, struct ChainBuilder *const cbPtr, Tcl_HashTable *const doneFilters, @@ -105,6 +124,10 @@ static int AddSimpleClassChainToCallContext(Class *classPtr, struct ChainBuilder *const cbPtr, Tcl_HashTable *const doneFilters, int flags, Class *const filterDecl); +static void AddSimpleClassDefineNamespaces(Class *classPtr, + DefineChain *const definePtr, int flags); +static inline void AddSimpleDefineNamespaces(Object *const oPtr, + DefineChain *const definePtr, int flags); static int CmpStr(const void *ptr1, const void *ptr2); static void DupMethodNameRep(Tcl_Obj *srcPtr, Tcl_Obj *dstPtr); static Tcl_NRPostProc FinalizeMethodRefs; @@ -1836,6 +1859,246 @@ TclOORenderCallChain( } /* + * ---------------------------------------------------------------------- + * + * TclOOGetDefineContextNamespace -- + * + * Responsible for determining which namespace to use for definitions. + * This is done by building a define chain, which models (strongly!) the + * way that a call chain works but with a different internal model. + * + * Then it walks the chain to find the first namespace name that actually + * resolves to an existing namespace. + * + * ---------------------------------------------------------------------- + */ + +#define DEFINE_CHAIN_STATIC_SIZE 4 /* Enough space to store most cases. */ + +Tcl_Namespace * +TclOOGetDefineContextNamespace( + Tcl_Interp *interp, /* In what interpreter should namespace names + * actually be resolved. */ + Object *oPtr, /* The object to get the context for. */ + int forClass) /* What sort of context are we looking for. + * If true, we are going to use this for + * [oo::define], otherwise, we are going to + * use this for [oo::objdefine]. */ +{ + DefineChain define; + DefineEntry staticSpace[DEFINE_CHAIN_STATIC_SIZE]; + DefineEntry *entryPtr; + Tcl_Namespace *nsPtr = NULL; + int i; + + define.list = staticSpace; + define.num = 0; + define.size = DEFINE_CHAIN_STATIC_SIZE; + + /* + * Add the actual define locations. We have to do this twice to handle + * class mixins right. + */ + + AddSimpleDefineNamespaces(oPtr, &define, forClass | BUILDING_MIXINS); + AddSimpleDefineNamespaces(oPtr, &define, forClass); + + /* + * Go through the list until we find a namespace whose name we can + * resolve. + */ + + FOREACH_STRUCT(entryPtr, define) { + if (TclGetNamespaceFromObj(interp, entryPtr->namespaceName, + &nsPtr) == TCL_OK) { + break; + } + Tcl_ResetResult(interp); + } + if (define.list != staticSpace) { + ckfree(define.list); + } + if (!nsPtr) { + Tcl_AppendResult(interp, "no definition namespace available", NULL); + return NULL; + } + return nsPtr; +} + +/* + * ---------------------------------------------------------------------- + * + * AddSimpleDefineNamespaces -- + * + * Adds to the definition chain all the definitions provided by an + * object's class and its mixins, taking into account everything they + * inherit from. + * + * ---------------------------------------------------------------------- + */ + +static inline void +AddSimpleDefineNamespaces( + Object *const oPtr, /* Object to add define chain entries for. */ + DefineChain *const definePtr, + /* Where to add the define chain entries. */ + int flags) /* What sort of define chain are we + * building. */ +{ + Class *mixinPtr; + int i; + + FOREACH(mixinPtr, oPtr->mixins) { + AddSimpleClassDefineNamespaces(mixinPtr, definePtr, + flags | TRAVERSED_MIXIN); + } + + AddSimpleClassDefineNamespaces(oPtr->selfCls, definePtr, flags); +} + +/* + * ---------------------------------------------------------------------- + * + * AddSimpleClassDefineNamespaces -- + * + * Adds to the definition chain all the definitions provided by a class + * and its superclasses and its class mixins. + * + * ---------------------------------------------------------------------- + */ + +static void +AddSimpleClassDefineNamespaces( + Class *classPtr, /* Class to add the define chain entries for. */ + DefineChain *const definePtr, + /* Where to add the define chain entries. */ + int flags) /* What sort of define chain are we + * building. */ +{ + int i; + Class *superPtr; + + /* + * We hard-code the tail-recursive form. It's by far the most common case + * *and* it is much more gentle on the stack. + */ + + tailRecurse: + FOREACH(superPtr, classPtr->mixins) { + AddSimpleClassDefineNamespaces(superPtr, definePtr, + flags | TRAVERSED_MIXIN); + } + + if (flags & ~(TRAVERSED_MIXIN | BUILDING_MIXINS)) { + AddDefinitionNamespaceToChain(classPtr, classPtr->clsDefinitionNs, + definePtr, flags); + } else { + AddDefinitionNamespaceToChain(classPtr, classPtr->objDefinitionNs, + definePtr, flags); + } + + switch (classPtr->superclasses.num) { + case 1: + classPtr = classPtr->superclasses.list[0]; + goto tailRecurse; + default: + FOREACH(superPtr, classPtr->superclasses) { + AddSimpleClassDefineNamespaces(superPtr, definePtr, flags); + } + case 0: + return; + } +} + +/* + * ---------------------------------------------------------------------- + * + * AddDefinitionNamespaceToChain -- + * + * Adds a single item to the definition chain (if it is meaningful), + * reallocating the space for the chain if necessary. + * + * ---------------------------------------------------------------------- + */ + +static inline void +AddDefinitionNamespaceToChain( + Class *definerCls, /* What class defines this entry. */ + Tcl_Obj *namespaceName, /* The name for this entry (or NULL, a + * no-op). */ + DefineChain *const definePtr, + /* The define chain to add the method + * implementation to. */ + int flags) /* Used to check if we're mixin-consistent + * only. Mixin-consistent means that either + * we're looking to add things from a mixin + * and we have passed a mixin, or we're not + * looking to add things from a mixin and have + * not passed a mixin. */ +{ + int i; + + /* + * Return if this entry is blank. This is also where we enforce + * mixin-consistency. + */ + + if (namespaceName == NULL || !MIXIN_CONSISTENT(flags)) { + return; + } + + /* + * First test whether the method is already in the call chain. + */ + + for (i=0 ; inum ; i++) { + if (definePtr->list[i].definerCls == definerCls) { + /* + * Call chain semantics states that methods come as *late* in the + * call chain as possible. This is done by copying down the + * following methods. Note that this does not change the number of + * method invocations in the call chain; it just rearranges them. + * + * We skip changing anything if the place we found was already at + * the end of the list. + */ + + if (i < definePtr->num - 1) { + memmove(&definePtr->list[i], &definePtr->list[i + 1], + sizeof(DefineEntry) * (definePtr->num - i - 1)); + definePtr->list[i].definerCls = definerCls; + definePtr->list[i].namespaceName = namespaceName; + } + return; + } + } + + /* + * Need to really add the define. This is made a bit more complex by the + * fact that we are using some "static" space initially, and only start + * realloc-ing if the chain gets long. + */ + + if (definePtr->num == definePtr->size) { + definePtr->size *= 2; + if (definePtr->num == DEFINE_CHAIN_STATIC_SIZE) { + DefineEntry *staticList = definePtr->list; + + definePtr->list = + ckalloc(sizeof(DefineEntry) * definePtr->size); + memcpy(definePtr->list, staticList, + sizeof(DefineEntry) * definePtr->num); + } else { + definePtr->list = ckrealloc(definePtr->list, + sizeof(DefineEntry) * definePtr->size); + } + } + definePtr->list[i].definerCls = definerCls; + definePtr->list[i].namespaceName = namespaceName; + definePtr->num++; +} + +/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index b4ff283..618b1e0 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -1053,7 +1053,7 @@ TclOODefineObjCmd( int objc, Tcl_Obj *const *objv) { - Foundation *fPtr = TclOOGetFoundation(interp); + Tcl_Namespace *nsPtr; Object *oPtr; int result; @@ -1068,7 +1068,7 @@ TclOODefineObjCmd( } if (oPtr->classPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "%s does not refer to a class",TclGetString(objv[1]))); + "%s does not refer to a class", TclGetString(objv[1]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS", TclGetString(objv[1]), NULL); return TCL_ERROR; @@ -1079,7 +1079,11 @@ TclOODefineObjCmd( * command(s). */ - if (InitDefineContext(interp, fPtr->defineNs, oPtr, objc,objv) != TCL_OK){ + nsPtr = TclOOGetDefineContextNamespace(interp, oPtr, 1); + if (nsPtr == NULL) { + return TCL_ERROR; + } + if (InitDefineContext(interp, nsPtr, oPtr, objc, objv) != TCL_OK) { return TCL_ERROR; } @@ -1095,7 +1099,7 @@ TclOODefineObjCmd( } TclDecrRefCount(objNameObj); } else { - result = MagicDefinitionInvoke(interp, fPtr->defineNs, 2, objc, objv); + result = MagicDefinitionInvoke(interp, nsPtr, 2, objc, objv); } TclOODecrRefCount(oPtr); @@ -1128,7 +1132,7 @@ TclOOObjDefObjCmd( int objc, Tcl_Obj *const *objv) { - Foundation *fPtr = TclOOGetFoundation(interp); + Tcl_Namespace *nsPtr; Object *oPtr; int result; @@ -1147,7 +1151,11 @@ TclOOObjDefObjCmd( * command(s). */ - if (InitDefineContext(interp, fPtr->objdefNs, oPtr, objc,objv) != TCL_OK){ + nsPtr = TclOOGetDefineContextNamespace(interp, oPtr, 0); + if (nsPtr == NULL) { + return TCL_ERROR; + } + if (InitDefineContext(interp, nsPtr, oPtr, objc, objv) != TCL_OK) { return TCL_ERROR; } @@ -1163,7 +1171,7 @@ TclOOObjDefObjCmd( } TclDecrRefCount(objNameObj); } else { - result = MagicDefinitionInvoke(interp, fPtr->objdefNs, 2, objc, objv); + result = MagicDefinitionInvoke(interp, nsPtr, 2, objc, objv); } TclOODecrRefCount(oPtr); @@ -1196,7 +1204,7 @@ TclOODefineSelfObjCmd( int objc, Tcl_Obj *const *objv) { - Foundation *fPtr = TclOOGetFoundation(interp); + Tcl_Namespace *nsPtr; Object *oPtr; int result, private; @@ -1217,7 +1225,11 @@ TclOODefineSelfObjCmd( * command(s). */ - if (InitDefineContext(interp, fPtr->objdefNs, oPtr, objc,objv) != TCL_OK){ + nsPtr = TclOOGetDefineContextNamespace(interp, oPtr, 0); + if (nsPtr == NULL) { + return TCL_ERROR; + } + if (InitDefineContext(interp, nsPtr, oPtr, objc, objv) != TCL_OK) { return TCL_ERROR; } if (private) { @@ -1236,7 +1248,7 @@ TclOODefineSelfObjCmd( } TclDecrRefCount(objNameObj); } else { - result = MagicDefinitionInvoke(interp, fPtr->objdefNs, 1, objc, objv); + result = MagicDefinitionInvoke(interp, nsPtr, 1, objc, objv); } TclOODecrRefCount(oPtr); diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index 47e5cf0..c92ac49 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -304,6 +304,24 @@ typedef struct Class { PrivateVariableList privateVariables; /* Configurations for the variable resolver * used inside methods. */ + Tcl_Obj *clsDefinitionNs; /* Name of the namespace to use for + * definitions commands of instances of this + * class in when those instances are defined + * as classes. If NULL, use the value from the + * class hierarchy. It's an error at + * [oo::define] call time if this namespace is + * defined but doesn't exist; we also check at + * setting time but don't check between + * times. */ + Tcl_Obj *objDefinitionNs; /* Name of the namespace to use for + * definitions commands of instances of this + * class in when those instances are defined + * as instances. If NULL, use the value from + * the class hierarchy. It's an error at + * [oo::objdefine]/[self] call time if this + * namespace is defined but doesn't exist; we + * also check at setting time but don't check + * between times. */ } Class; /* @@ -553,6 +571,8 @@ MODULE_SCOPE CallContext *TclOOGetCallContext(Object *oPtr, Tcl_Obj *methodNameObj, int flags, Object *contextObjPtr, Class *contextClsPtr, Tcl_Obj *cacheInThisObj); +MODULE_SCOPE Tcl_Namespace *TclOOGetDefineContextNamespace( + Tcl_Interp *interp, Object *oPtr, int forClass); MODULE_SCOPE CallChain *TclOOGetStereotypeCallChain(Class *clsPtr, Tcl_Obj *methodNameObj, int flags); MODULE_SCOPE Foundation *TclOOGetFoundation(Tcl_Interp *interp); -- cgit v0.12 From af5d98388ac96c197412d002421caaf3b0ed7949 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 28 Oct 2018 08:22:21 +0000 Subject: Definition and introspection commands. --- generic/tclOO.c | 1 + generic/tclOOCall.c | 8 +-- generic/tclOODefineCmds.c | 134 ++++++++++++++++++++++++++++++++++++++++------ generic/tclOOInfo.c | 52 ++++++++++++++++++ generic/tclOOInt.h | 3 ++ tests/oo.test | 2 +- 6 files changed, 179 insertions(+), 21 deletions(-) diff --git a/generic/tclOO.c b/generic/tclOO.c index 1860796..0cbddcd 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -26,6 +26,7 @@ static const struct { int flag; } defineCmds[] = { {"constructor", TclOODefineConstructorObjCmd, 0}, + {"definitionnamespace", TclOODefineDefnNsObjCmd, 0}, {"deletemethod", TclOODefineDeleteMethodObjCmd, 0}, {"destructor", TclOODefineDestructorObjCmd, 0}, {"export", TclOODefineExportObjCmd, 0}, diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c index 39cd1ba..539432e 100644 --- a/generic/tclOOCall.c +++ b/generic/tclOOCall.c @@ -1870,6 +1870,10 @@ TclOORenderCallChain( * Then it walks the chain to find the first namespace name that actually * resolves to an existing namespace. * + * Returns: + * Name of namespace, or NULL if none can be found. Note that this + * function does *not* set an error message in the interpreter on failure. + * * ---------------------------------------------------------------------- */ @@ -1918,10 +1922,6 @@ TclOOGetDefineContextNamespace( if (define.list != staticSpace) { ckfree(define.list); } - if (!nsPtr) { - Tcl_AppendResult(interp, "no definition namespace available", NULL); - return NULL; - } return nsPtr; } diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index 618b1e0..7d1b051 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -63,6 +63,8 @@ static inline int MagicDefinitionInvoke(Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); static inline Class * GetClassInOuterContext(Tcl_Interp *interp, Tcl_Obj *className, const char *errMsg); +static inline Tcl_Namespace *GetNamespaceInOuterContext(Tcl_Interp *interp, + Tcl_Obj *namespaceName); static inline int InitDefineContext(Tcl_Interp *interp, Tcl_Namespace *namespacePtr, Object *oPtr, int objc, Tcl_Obj *const objv[]); @@ -828,8 +830,7 @@ InitDefineContext( if (namespacePtr == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "cannot process definitions; support namespace deleted", - -1)); + "no definition namespace available", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; } @@ -888,12 +889,12 @@ TclOOGetDefineCmdContext( /* * ---------------------------------------------------------------------- * - * GetClassInOuterContext -- + * GetClassInOuterContext, GetNamespaceInOuterContext -- * - * Wrapper round Tcl_GetObjectFromObj to perform the lookup in the - * context that called oo::define (or equivalent). Note that this may - * have to go up multiple levels to get the level that we started doing - * definitions at. + * Wrappers round Tcl_GetObjectFromObj and TclGetNamespaceFromObj to + * perform the lookup in the context that called oo::define (or + * equivalent). Note that this may have to go up multiple levels to get + * the level that we started doing definitions at. * * ---------------------------------------------------------------------- */ @@ -928,6 +929,31 @@ GetClassInOuterContext( } return oPtr->classPtr; } + +static inline Tcl_Namespace * +GetNamespaceInOuterContext( + Tcl_Interp *interp, + Tcl_Obj *namespaceName) +{ + Interp *iPtr = (Interp *) interp; + Tcl_Namespace *nsPtr; + int result; + CallFrame *savedFramePtr = iPtr->varFramePtr; + + while (iPtr->varFramePtr->isProcCallFrame == FRAME_IS_OO_DEFINE + || iPtr->varFramePtr->isProcCallFrame == PRIVATE_FRAME) { + if (iPtr->varFramePtr->callerVarPtr == NULL) { + Tcl_Panic("getting outer context when already in global context"); + } + iPtr->varFramePtr = iPtr->varFramePtr->callerVarPtr; + } + result = TclGetNamespaceFromObj(interp, namespaceName, &nsPtr); + iPtr->varFramePtr = savedFramePtr; + if (result != TCL_OK) { + return NULL; + } + return nsPtr; +} /* * ---------------------------------------------------------------------- @@ -1080,9 +1106,6 @@ TclOODefineObjCmd( */ nsPtr = TclOOGetDefineContextNamespace(interp, oPtr, 1); - if (nsPtr == NULL) { - return TCL_ERROR; - } if (InitDefineContext(interp, nsPtr, oPtr, objc, objv) != TCL_OK) { return TCL_ERROR; } @@ -1152,9 +1175,6 @@ TclOOObjDefObjCmd( */ nsPtr = TclOOGetDefineContextNamespace(interp, oPtr, 0); - if (nsPtr == NULL) { - return TCL_ERROR; - } if (InitDefineContext(interp, nsPtr, oPtr, objc, objv) != TCL_OK) { return TCL_ERROR; } @@ -1226,9 +1246,6 @@ TclOODefineSelfObjCmd( */ nsPtr = TclOOGetDefineContextNamespace(interp, oPtr, 0); - if (nsPtr == NULL) { - return TCL_ERROR; - } if (InitDefineContext(interp, nsPtr, oPtr, objc, objv) != TCL_OK) { return TCL_ERROR; } @@ -1546,6 +1563,91 @@ TclOODefineConstructorObjCmd( /* * ---------------------------------------------------------------------- * + * TclOODefineDefnNsObjCmd -- + * + * Implementation of the "definitionnamespace" subcommand of the + * "oo::define" command. + * + * ---------------------------------------------------------------------- + */ + +int +TclOODefineDefnNsObjCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + static const char *kindList[] = { + "-class", + "-instance", + NULL + }; + int kind = 0; + Object *oPtr; + Tcl_Namespace *nsPtr; + Tcl_Obj *nsNamePtr, **storagePtr; + + oPtr = (Object *) TclOOGetDefineCmdContext(interp); + if (oPtr == NULL) { + return TCL_ERROR; + } + if (!oPtr->classPtr) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to misuse API", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); + return TCL_ERROR; + } + if (oPtr->flags & (ROOT_OBJECT | ROOT_CLASS)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "may not modify the definition namespace of the root classes", + -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); + return TCL_ERROR; + } + + /* + * Parse the arguments and work out what the user wants to do. + */ + + if (objc != 2 && objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "?kind? namespace"); + return TCL_ERROR; + } + if (objc == 3 && Tcl_GetIndexFromObj(interp, objv[1], kindList, "kind", 0, + &kind) != TCL_OK) { + return TCL_ERROR; + } + if (!Tcl_GetString(objv[objc - 1])[0]) { + nsNamePtr = NULL; + } else { + nsPtr = GetNamespaceInOuterContext(interp, objv[objc - 1]); + if (nsPtr == NULL) { + return TCL_ERROR; + } + nsNamePtr = Tcl_NewStringObj(nsPtr->fullName, -1); + Tcl_IncrRefCount(nsNamePtr); + } + + /* + * Update the correct field of the class definition. + */ + + if (kind) { + storagePtr = &oPtr->classPtr->objDefinitionNs; + } else { + storagePtr = &oPtr->classPtr->clsDefinitionNs; + } + if (*storagePtr != NULL) { + Tcl_DecrRefCount(*storagePtr); + } + *storagePtr = nsNamePtr; + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * * TclOODefineDeleteMethodObjCmd -- * * Implementation of the "deletemethod" subcommand of the "oo::define" diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c index fe433e4..abae835 100644 --- a/generic/tclOOInfo.c +++ b/generic/tclOOInfo.c @@ -33,6 +33,7 @@ static Tcl_ObjCmdProc InfoObjectVariablesCmd; static Tcl_ObjCmdProc InfoClassCallCmd; static Tcl_ObjCmdProc InfoClassConstrCmd; static Tcl_ObjCmdProc InfoClassDefnCmd; +static Tcl_ObjCmdProc InfoClassDefnNsCmd; static Tcl_ObjCmdProc InfoClassDestrCmd; static Tcl_ObjCmdProc InfoClassFiltersCmd; static Tcl_ObjCmdProc InfoClassForwardCmd; @@ -73,6 +74,7 @@ static const EnsembleImplMap infoClassCmds[] = { {"call", InfoClassCallCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, {"constructor", InfoClassConstrCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"definition", InfoClassDefnCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, + {"definitionnamespace", InfoClassDefnNsCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, {"destructor", InfoClassDestrCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"filters", InfoClassFiltersCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"forward", InfoClassForwardCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, @@ -1033,6 +1035,56 @@ InfoClassDefnCmd( /* * ---------------------------------------------------------------------- * + * InfoClassDefnNsCmd -- + * + * Implements [info class definitionnamespace $clsName ?$kind?] + * + * ---------------------------------------------------------------------- + */ + +static int +InfoClassDefnNsCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + static const char *kindList[] = { + "-class", + "-instance", + NULL + }; + int kind = 0; + Tcl_Obj *nsNamePtr; + Class *clsPtr; + + if (objc != 2 && objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "className ?kind?"); + return TCL_ERROR; + } + clsPtr = GetClassFromObj(interp, objv[1]); + if (clsPtr == NULL) { + return TCL_ERROR; + } + if (objc == 3 && Tcl_GetIndexFromObj(interp, objv[2], kindList, "kind", 0, + &kind) != TCL_OK) { + return TCL_ERROR; + } + + if (kind) { + nsNamePtr = clsPtr->clsDefinitionNs; + } else { + nsNamePtr = clsPtr->objDefinitionNs; + } + if (nsNamePtr) { + Tcl_SetObjResult(interp, nsNamePtr); + } + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * * InfoClassDestrCmd -- * * Implements [info class destructor $clsName] diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index c92ac49..cde8d91 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -459,6 +459,9 @@ MODULE_SCOPE int TclOOObjDefObjCmd(ClientData clientData, MODULE_SCOPE int TclOODefineConstructorObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); +MODULE_SCOPE int TclOODefineDefnNsObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const *objv); MODULE_SCOPE int TclOODefineDeleteMethodObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); diff --git a/tests/oo.test b/tests/oo.test index 37c4495..2a266a7 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -2519,7 +2519,7 @@ test oo-17.3 {OO: class introspection} -setup { } -result {"foo" is not a class} test oo-17.4 {OO: class introspection} -body { info class gorp oo::object -} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be call, constructor, definition, destructor, filters, forward, instances, methods, methodtype, mixins, subclasses, superclasses, or variables} +} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be call, constructor, definition, definitionnamespace, destructor, filters, forward, instances, methods, methodtype, mixins, subclasses, superclasses, or variables} test oo-17.5 {OO: class introspection} -setup { oo::class create testClass } -body { -- cgit v0.12 From 96b9e6e871228c0a269c0b3310b987186e1a89c7 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 28 Oct 2018 10:04:08 +0000 Subject: Missing -DUNICODE in makefile.vc --- win/makefile.vc | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/win/makefile.vc b/win/makefile.vc index 95a34d7..cc340a8 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -893,9 +893,9 @@ $(TMP_DIR)\tclWinReg.obj: $(WINDIR)\tclWinReg.c $(TMP_DIR)\tclWinDde.obj: $(WINDIR)\tclWinDde.c !if $(STATIC_BUILD) - $(cc32) $(TCL_CFLAGS) -DTCL_THREADS=1 -DSTATIC_BUILD -Fo$@ $? + $(cc32) $(TCL_CFLAGS) -DTCL_THREADS=1 -DSTATIC_BUILD -DUNICODE -D_UNICODE -Fo$@ $? !else - $(cc32) $(TCL_CFLAGS) -DTCL_THREADS=1 -DUSE_TCL_STUBS -Fo$@ $? + $(cc32) $(TCL_CFLAGS) -DTCL_THREADS=1 -DUSE_TCL_STUBS -DUNICODE -D_UNICODE -Fo$@ $? !endif -- cgit v0.12 From 56f89b98500c1b7f96c8c5eca2a349a77a3ffa65 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 28 Oct 2018 12:48:53 +0000 Subject: Test cases (and some fixes) --- generic/tclOO.c | 11 +- generic/tclOOInfo.c | 4 +- generic/tclOOScript.h | 4 +- generic/tclOOScript.tcl | 6 +- tests/oo.test | 259 +++++++++++++++++++++++++++++++++++++++++++++++- 5 files changed, 268 insertions(+), 16 deletions(-) diff --git a/generic/tclOO.c b/generic/tclOO.c index 0cbddcd..f68e4f3 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -446,6 +446,7 @@ InitClassSystemRoots( { Class fakeCls; Object fakeObject; + Tcl_Obj *defNsName; /* Stand up a phony class for bootstrapping. */ fPtr->objectCls = &fakeCls; @@ -473,8 +474,9 @@ InitClassSystemRoots( fPtr->objectCls->thisPtr->flags |= ROOT_OBJECT; fPtr->objectCls->flags |= ROOT_OBJECT; - TclNewLiteralStringObj(fPtr->objectCls->objDefinitionNs, "::oo::objdefine"); - Tcl_IncrRefCount(fPtr->objectCls->objDefinitionNs); + TclNewLiteralStringObj(defNsName, "::oo::objdefine"); + fPtr->objectCls->objDefinitionNs = defNsName; + Tcl_IncrRefCount(defNsName); fPtr->classCls = TclOOAllocClass(interp, AllocObject(interp, "class", (Namespace *)fPtr->ooNs, NULL)); @@ -503,8 +505,9 @@ InitClassSystemRoots( fPtr->classCls->thisPtr->flags |= ROOT_CLASS; fPtr->classCls->flags |= ROOT_CLASS; - TclNewLiteralStringObj(fPtr->objectCls->clsDefinitionNs, "::oo::define"); - Tcl_IncrRefCount(fPtr->objectCls->clsDefinitionNs); + TclNewLiteralStringObj(defNsName, "::oo::define"); + fPtr->classCls->clsDefinitionNs = defNsName; + Tcl_IncrRefCount(defNsName); /* Standard initialization for new Objects */ TclOOAddToSubclasses(fPtr->classCls, fPtr->objectCls); diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c index abae835..8c45e1b 100644 --- a/generic/tclOOInfo.c +++ b/generic/tclOOInfo.c @@ -1072,9 +1072,9 @@ InfoClassDefnNsCmd( } if (kind) { - nsNamePtr = clsPtr->clsDefinitionNs; - } else { nsNamePtr = clsPtr->objDefinitionNs; + } else { + nsNamePtr = clsPtr->clsDefinitionNs; } if (nsNamePtr) { Tcl_SetObjResult(interp, nsNamePtr); diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index 2213ce3..ab637dd 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -98,9 +98,9 @@ static const char *tclOOSetupScript = "\t\t\tif {![info object isa class $d]} {\n" "\t\t\t\tcontinue\n" "\t\t\t}\n" -"\t\t\tdefine $delegate superclass -append $d\n" +"\t\t\tdefine $delegate ::oo::define::superclass -append $d\n" "\t\t}\n" -"\t\tobjdefine $class mixin -append $delegate\n" +"\t\tobjdefine $class ::oo::objdefine::mixin -append $delegate\n" "\t}\n" "\tproc UpdateClassDelegatesAfterClone {originObject targetObject} {\n" "\t\tset originDelegate [DelegateName $originObject]\n" diff --git a/generic/tclOOScript.tcl b/generic/tclOOScript.tcl index a48eab5..5e0145f 100644 --- a/generic/tclOOScript.tcl +++ b/generic/tclOOScript.tcl @@ -153,9 +153,9 @@ if {![info object isa class $d]} { continue } - define $delegate superclass -append $d + define $delegate ::oo::define::superclass -append $d } - objdefine $class mixin -append $delegate + objdefine $class ::oo::objdefine::mixin -append $delegate } # ---------------------------------------------------------------------- @@ -176,7 +176,7 @@ && ![info object isa class $targetDelegate] } then { copy $originDelegate $targetDelegate - objdefine $targetObject mixin -set \ + objdefine $targetObject ::oo::objdefine::mixin -set \ {*}[lmap c [info object mixin $targetObject] { if {$c eq $originDelegate} {set targetDelegate} {set c} }] diff --git a/tests/oo.test b/tests/oo.test index 2a266a7..459db8e 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -329,16 +329,17 @@ test oo-1.21 {basic test of OO functionality: default relations} -setup { set fresh [interp create] } -body { lmap x [$fresh eval { + set initials {::oo::object ::oo::class ::oo::Slot} foreach cmd {instances subclasses mixins superclass} { - foreach initial {object class Slot} { - lappend x [info class $cmd ::oo::$initial] + foreach initial $initials { + lappend x [info class $cmd $initial] } } - foreach initial {object class Slot} { - lappend x [info object class ::oo::$initial] + foreach initial $initials { + lappend x [info object class $initial] } return $x - }] {lsort [lmap y $x {if {[string match *::delegate $y]} continue; set y}]} + }] {lsort [lsearch -all -not -inline $x *::delegate]} } -cleanup { interp delete $fresh } -result {{} {::oo::Slot ::oo::abstract ::oo::class ::oo::object ::oo::singleton} {::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable} {::oo::Slot ::oo::class} {::oo::abstract ::oo::singleton} {} {} {} {} {} ::oo::object ::oo::object ::oo::class ::oo::class ::oo::class} @@ -5076,6 +5077,254 @@ test oo-41.3 {TIP 478: myclass command calls unexported methods, via forward} -s } -cleanup { parent destroy } -result {1 {this is ::cls1}} + +test oo-42.1 {TIP 524: definition namespace control: introspection} { + info class definitionnamespace oo::object +} {} +test oo-42.2 {TIP 524: definition namespace control: introspection} { + info class definitionnamespace oo::object -class +} {} +test oo-42.3 {TIP 524: definition namespace control: introspection} { + info class definitionnamespace oo::object -instance +} ::oo::objdefine +test oo-42.4 {TIP 524: definition namespace control: introspection} -body { + info class definitionnamespace oo::object -gorp +} -returnCodes error -result {bad kind "-gorp": must be -class or -instance} +test oo-42.5 {TIP 524: definition namespace control: introspection} -body { + info class definitionnamespace oo::object -class x +} -returnCodes error -result {wrong # args: should be "info class definitionnamespace className ?kind?"} +test oo-42.6 {TIP 524: definition namespace control: introspection} { + info class definitionnamespace oo::class +} ::oo::define +test oo-42.7 {TIP 524: definition namespace control: introspection} { + info class definitionnamespace oo::class -class +} ::oo::define +test oo-42.8 {TIP 524: definition namespace control: introspection} { + info class definitionnamespace oo::class -instance +} {} + +test oo-43.1 {TIP 524: definition namespace control: semantics} -setup { + oo::class create parent + namespace eval foodef {} +} -body { + namespace eval foodef { + proc sparkle {} {return ok} + } + oo::class create foocls { + superclass oo::class parent + definitionnamespace foodef + } + oo::class create foo { + superclass parent + self class foocls + } + oo::define foo { + sparkle + } +} -cleanup { + parent destroy + namespace delete foodef +} -result ok +test oo-43.2 {TIP 524: definition namespace control: semantics} -setup { + oo::class create parent + namespace eval foodef {} + unset -nocomplain ::result +} -body { + namespace eval foodef { + namespace path ::oo::define + proc sparkle {} {return ok} + } + oo::class create foocls { + superclass oo::class parent + definitionnamespace foodef + } + foocls create foo { + superclass parent + lappend ::result [sparkle] + } + return $result +} -cleanup { + parent destroy + namespace delete foodef +} -result ok +test oo-43.3 {TIP 524: definition namespace control: semantics} -setup { + oo::class create parent + namespace eval foodef {} + unset -nocomplain ::result +} -body { + namespace eval foodef { + namespace path ::oo::define + proc sparkle {} {return ok} + } + oo::class create foocls { + superclass oo::class parent + definitionnamespace -class foodef + } + foocls create foo { + superclass parent + lappend ::result [sparkle] + } + return $result +} -cleanup { + parent destroy + namespace delete foodef +} -result ok +test oo-43.4 {TIP 524: definition namespace control: semantics} -setup { + oo::class create parent + namespace eval foodef {} +} -body { + namespace eval foodef { + namespace path ::oo::objdefine + proc sparkle {} {return ok} + } + oo::class create foocls { + superclass oo::class parent + definitionnamespace -instance foodef + } + foocls create foo { + sparkle + } +} -returnCodes error -cleanup { + parent destroy + namespace delete foodef +} -result {invalid command name "sparkle"} +test oo-43.5 {TIP 524: definition namespace control: semantics} -setup { + oo::class create parent + namespace eval foodef {} +} -body { + namespace eval foodef { + namespace path ::oo::objdefine + proc sparkle {} {return ok} + } + oo::class create foocls { + superclass oo::class parent + definitionnamespace foodef + } + namespace delete foodef + foocls create foo { + sparkle + } +} -returnCodes error -cleanup { + parent destroy + catch {namespace delete foodef} +} -result {invalid command name "sparkle"} +test oo-43.6 {TIP 524: definition namespace control: semantics} -setup { + oo::class create parent + namespace eval foodef {} + unset -nocomplain result +} -body { + namespace eval foodef { + namespace path ::oo::objdefine + proc sparkle {} {return ok} + } + oo::class create foocls { + superclass oo::class parent + definitionnamespace foodef + } + foocls create foo + lappend result [catch {oo::define foo sparkle} msg] $msg + namespace delete foodef + lappend result [catch {oo::define foo sparkle} msg] $msg + namespace eval foodef { + namespace path ::oo::objdefine + proc sparkle {} {return ok} + } + lappend result [catch {oo::define foo sparkle} msg] $msg +} -cleanup { + parent destroy + catch {namespace delete foodef} +} -result {0 ok 1 {invalid command name "sparkle"} 0 ok} +test oo-43.7 {TIP 524: definition namespace control: semantics} -setup { + oo::class create parent + namespace eval foodef {} +} -body { + namespace eval foodef { + namespace path ::oo::define + proc sparkle {x} {return ok} + } + oo::class create foocls { + superclass oo::class parent + definitionnamespace foodef + } + foocls create foo { + superclass parent + } + oo::define foo spar gorp +} -cleanup { + parent destroy + namespace delete foodef +} -result ok +test oo-43.8 {TIP 524: definition namespace control: semantics} -setup { + oo::class create parent + namespace eval foodef {} +} -body { + namespace eval foodef { + namespace path ::oo::objdefine + proc sparkle {} {return ok} + } + oo::class create foo { + superclass parent + definitionnamespace -instance foodef + } + oo::objdefine [foo new] { + method x y z + sparkle + } +} -cleanup { + parent destroy + namespace delete foodef +} -result ok +test oo-43.9 {TIP 524: definition namespace control: syntax} -body { + oo::class create foo { + definitionnamespace -gorp foodef + } +} -returnCodes error -result {bad kind "-gorp": must be -class or -instance} +test oo-43.10 {TIP 524: definition namespace control: syntax} -body { + oo::class create foo { + definitionnamespace -class foodef x + } +} -returnCodes error -result {wrong # args: should be "definitionnamespace ?kind? namespace"} +test oo-43.11 {TIP 524: definition namespace control: syntax} -setup { + catch {namespace delete ::no_such_ns} +} -body { + oo::class create foo { + definitionnamespace -class ::no_such_ns + } +} -returnCodes error -result {namespace "::no_such_ns" not found} +test oo-43.12 {TIP 524: definition namespace control: user-level introspection} -setup { + oo::class create parent + namespace eval foodef {} +} -body { + namespace eval foodef {} + oo::class create foo { + superclass oo::class parent + } + list [info class definitionnamespace foo] \ + [oo::define foo definitionnamespace foodef] \ + [info class definitionnamespace foo] \ + [oo::define foo definitionnamespace {}] \ + [info class definitionnamespace foo] +} -cleanup { + parent destroy + namespace delete foodef +} -result {{} {} ::foodef {} {}} +test oo-43.13 {TIP 524: definition namespace control: user-level introspection} -setup { + oo::class create parent + namespace eval foodef {} +} -body { + namespace eval foodef {} + oo::class create foo { + superclass parent + } + list [info class definitionnamespace foo -instance] \ + [oo::define foo definitionnamespace -instance foodef] \ + [info class definitionnamespace foo -instance] \ + [oo::define foo definitionnamespace -instance {}] \ + [info class definitionnamespace foo -instance] +} -cleanup { + parent destroy + namespace delete foodef +} -result {{} {} ::foodef {} {}} cleanupTests return -- cgit v0.12 From de664683019ed4dbba048b44b3529b71daa198c0 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 28 Oct 2018 15:36:55 +0000 Subject: Documentation --- doc/define.n | 241 +++++++++++++++++++++++++++++++++++++++++------------------ doc/info.n | 18 +++++ 2 files changed, 187 insertions(+), 72 deletions(-) diff --git a/doc/define.n b/doc/define.n index 883d5fa..7be9e9b 100644 --- a/doc/define.n +++ b/doc/define.n @@ -34,7 +34,11 @@ either the \fIdefScript\fR argument or by the \fIsubcommand\fR and following \fIarg\fR arguments; when the second is present, it is exactly as if all the arguments from \fIsubcommand\fR onwards are made into a list and that list is used as the \fIdefScript\fR argument. -.SS "CONFIGURING CLASSES" +.PP +Note that the constructor for \fBoo::class\fR will call \fBoo::define\fR on +the script argument that it is provided. This is a convenient way to create +and define a class in one step. +.SH "CONFIGURING CLASSES" .PP The following commands are supported in the \fIdefScript\fR for \fBoo::define\fR, each of which may also be used in the \fIsubcommand\fR form: @@ -70,13 +74,11 @@ namespace of the constructor will be a namespace that is unique to the object being constructed. Within the constructor, the \fBnext\fR command should be used to call the superclasses' constructors. If \fIbodyScript\fR is the empty string, the constructor will be deleted. -.TP -\fBdeletemethod\fI name\fR ?\fIname ...\fR? -. -This deletes each of the methods called \fIname\fR from a class. The methods -must have previously existed in that class. Does not affect the superclasses -of the class, nor does it affect the subclasses or instances of the class -(except when they have a call chain through the class being modified). +.RS +.PP +Classes do not need to have a constructor defined. If none is specified, the +superclass's constructor will be used instead. +.RE .TP \fBdestructor\fI bodyScript\fR . @@ -102,16 +104,6 @@ class being defined. Note that the methods themselves may be actually defined by a superclass; subclass exports override superclass visibility, and may in turn be overridden by instances. .TP -\fBfilter\fR ?\fI\-slotOperation\fR? ?\fImethodName ...\fR? -. -This slot (see \fBSLOTTED DEFINITIONS\fR below) -sets or updates the list of method names that are used to guard whether -method call to instances of the class may be called and what the method's -results are. Each \fImethodName\fR names a single filtering method (which may -be exposed or not exposed); it is not an error for a non-existent method to be -named since they may be defined by subclasses. -By default, this slot works by appending. -.TP \fBforward\fI name cmdName \fR?\fIarg ...\fR? . This creates or updates a forwarded method called \fIname\fR. The method is @@ -159,14 +151,6 @@ below), this command creates private procedure-like methods. .VE TIP500 .RE .TP -\fBmixin\fR ?\fI\-slotOperation\fR? ?\fIclassName ...\fR? -. -This slot (see \fBSLOTTED DEFINITIONS\fR below) -sets or updates the list of additional classes that are to be mixed into -all the instances of the class being defined. Each \fIclassName\fR argument -names a single class that is to be mixed in. -By default, this slot works by replacement. -.TP \fBprivate \fIcmd arg...\fR .TP \fBprivate \fIscript\fR @@ -186,16 +170,6 @@ context. .RE .VE TIP500 .TP -\fBrenamemethod\fI fromName toName\fR -. -This renames the method called \fIfromName\fR in a class to \fItoName\fR. The -method must have previously existed in the class, and \fItoName\fR must not -previously refer to a method in that class. Does not affect the superclasses -of the class, nor does it affect the subclasses or instances of the class -(except when they have a call chain through the class being modified). Does -not change the export status of the method; if it was exported before, it will -be afterwards. -.TP \fBself\fI subcommand arg ...\fR .TP \fBself\fI script\fR @@ -269,23 +243,76 @@ namespace has a unique prefix that makes accidental use from other classes extremely unlikely. .VE TIP500 .RE -.SS "CONFIGURING OBJECTS" +.SS "ADVANCED CLASS CONFIGURATION OPTIONS" .PP -The following commands are supported in the \fIdefScript\fR for -\fBoo::objdefine\fR, each of which may also be used in the \fIsubcommand\fR -form: +The following definitions are also supported, but are not required in simple +programs: +.TP +\fBdefinitionnamespace\fR ?\fIkind\fR? \fInamespaceName\fR +.VS TIP524 +This allows control over what namespace will be used by the \fBoo::define\fR +and \fBoo::objdefine\fR commands to look up the definition commands they +use. When any object has a definition operation applied to it, \fIthe class that +it is an instance of\fR (and its superclasses and mixins) is consulted for +what definition namespace to use. \fBoo::define\fR gets the class definition +namespace, and \fB::oo::objdefine\fR gets the instance definition namespace, +but both otherwise use the identical lookup operation. +.RS +.PP +This sets the definition namespace of kind \fIkind\fR provided by the current +class to \fInamespaceName\fR. The \fInamespaceName\fR must refer to a +currently existing namespace, or must be the empty string (to stop the current +class from having such a namespace connected). The \fIkind\fR, if supplied, +must be either \fB\-class\fR (the default) or \fB\-instance\fR to specify the +whether the namespace for use with \fBoo::define\fR or \fBoo::objdefine\fR +respectively is being set. +.PP +The class \fBoo::object\fR has its instance namespace locked to +\fB::oo::objdefine\fR, and the class \fBoo::class\fR has its class namespace +locked to \fB::oo::define\fR. A consequence of this is that effective use of +this feature for classes requires the definition of a metaclass. +.RE +.VE TIP524 .TP -\fBclass\fI className\fR +\fBdeletemethod\fI name\fR ?\fIname ...\fR? . -This allows the class of an object to be changed after creation. Note that the -class's constructors are not called when this is done, and so the object may -well be in an inconsistent state unless additional configuration work is done. +This deletes each of the methods called \fIname\fR from a class. The methods +must have previously existed in that class. Does not affect the superclasses +of the class, nor does it affect the subclasses or instances of the class +(except when they have a call chain through the class being modified). .TP -\fBdeletemethod\fI name\fR ?\fIname ...\fR +\fBfilter\fR ?\fI\-slotOperation\fR? ?\fImethodName ...\fR? . -This deletes each of the methods called \fIname\fR from an object. The methods -must have previously existed in that object. Does not affect the classes that -the object is an instance of. +This slot (see \fBSLOTTED DEFINITIONS\fR below) +sets or updates the list of method names that are used to guard whether +method call to instances of the class may be called and what the method's +results are. Each \fImethodName\fR names a single filtering method (which may +be exposed or not exposed); it is not an error for a non-existent method to be +named since they may be defined by subclasses. +By default, this slot works by appending. +.TP +\fBmixin\fR ?\fI\-slotOperation\fR? ?\fIclassName ...\fR? +. +This slot (see \fBSLOTTED DEFINITIONS\fR below) +sets or updates the list of additional classes that are to be mixed into +all the instances of the class being defined. Each \fIclassName\fR argument +names a single class that is to be mixed in. +By default, this slot works by replacement. +.TP +\fBrenamemethod\fI fromName toName\fR +. +This renames the method called \fIfromName\fR in a class to \fItoName\fR. The +method must have previously existed in the class, and \fItoName\fR must not +previously refer to a method in that class. Does not affect the superclasses +of the class, nor does it affect the subclasses or instances of the class +(except when they have a call chain through the class being modified). Does +not change the export status of the method; if it was exported before, it will +be afterwards. +.SH "CONFIGURING OBJECTS" +.PP +The following commands are supported in the \fIdefScript\fR for +\fBoo::objdefine\fR, each of which may also be used in the \fIsubcommand\fR +form: .TP \fBexport\fI name \fR?\fIname ...\fR? . @@ -294,17 +321,6 @@ This arranges for each of the named methods, \fIname\fR, to be exported being defined. Note that the methods themselves may be actually defined by a class or superclass; object exports override class visibility. .TP -\fBfilter\fR ?\fI\-slotOperation\fR? ?\fImethodName ...\fR? -. -This slot (see \fBSLOTTED DEFINITIONS\fR below) -sets or updates the list of method names that are used to guard whether a -method call to the object may be called and what the method's results are. -Each \fImethodName\fR names a single filtering method (which may be exposed or -not exposed); it is not an error for a non-existent method to be named. Note -that the actual list of filters also depends on the filters set upon any -classes that the object is an instance of. -By default, this slot works by appending. -.TP \fBforward\fI name cmdName \fR?\fIarg ...\fR? . This creates or updates a forwarded object method called \fIname\fR. The @@ -363,19 +379,6 @@ difference in behavior when used in a private definition context. .RE .VE TIP500 .TP -\fBrenamemethod\fI fromName toName\fR -. -This renames the method called \fIfromName\fR in an object to \fItoName\fR. -The method must have previously existed in the object, and \fItoName\fR must -not previously refer to a method in that object. Does not affect the classes -that the object is an instance of. Does not change the export status of the -method; if it was exported before, it will be afterwards. -.TP -\fBself \fR -.VS TIP470 -This gives the name of the object currently being configured. -.VE TIP470 -.TP \fBunexport\fI name \fR?\fIname ...\fR? . This arranges for each of the named methods, \fIname\fR, to be not exported @@ -408,6 +411,46 @@ instance namespace has a unique prefix that makes accidental use from superclass methods extremely unlikely. .VE TIP500 .RE +.SS "ADVANCED OBJECT CONFIGURATION OPTIONS" +.PP +The following definitions are also supported, but are not required in simple +programs: +.TP +\fBclass\fI className\fR +. +This allows the class of an object to be changed after creation. Note that the +class's constructors are not called when this is done, and so the object may +well be in an inconsistent state unless additional configuration work is done. +.TP +\fBdeletemethod\fI name\fR ?\fIname ...\fR +. +This deletes each of the methods called \fIname\fR from an object. The methods +must have previously existed in that object. Does not affect the classes that +the object is an instance of. +.TP +\fBfilter\fR ?\fI\-slotOperation\fR? ?\fImethodName ...\fR? +. +This slot (see \fBSLOTTED DEFINITIONS\fR below) +sets or updates the list of method names that are used to guard whether a +method call to the object may be called and what the method's results are. +Each \fImethodName\fR names a single filtering method (which may be exposed or +not exposed); it is not an error for a non-existent method to be named. Note +that the actual list of filters also depends on the filters set upon any +classes that the object is an instance of. +By default, this slot works by appending. +.TP +\fBrenamemethod\fI fromName toName\fR +. +This renames the method called \fIfromName\fR in an object to \fItoName\fR. +The method must have previously existed in the object, and \fItoName\fR must +not previously refer to a method in that object. Does not affect the classes +that the object is an instance of. Does not change the export status of the +method; if it was exported before, it will be afterwards. +.TP +\fBself \fR +.VS TIP470 +This gives the name of the object currently being configured. +.VE TIP470 .SH "PRIVATE METHODS" .VS TIP500 When a class or instance has a private method, that private method can only be @@ -659,6 +702,60 @@ $g update "emailaddress=admins" \fI\(-> DB: update row ::oo::Obj125 with emailaddress=admins\fR .CE .VE TIP478 +.PP +.VS TIP524 +This example shows how to make a custom definition for a class. Note that it +explicitly includes delegation to the existing definition commands via +\fBnamespace path\fR. +.PP +.CS +namespace eval myDefinitions { + # Delegate to existing definitions where not overridden + namespace path \fB::oo::define\fR + + # A custom type of method + proc exprmethod {name arguments body} { + tailcall \fBmethod\fR $name $arguments [list expr $body] + } + + # A custom way of building a constructor + proc parameters args { + uplevel 1 [list \fBvariable\fR {*}$args] + set body [join [lmap a $args { + string map [list VAR $a] { + set [my varname VAR] [expr {double($VAR)}] + } + }] ";"] + tailcall \fBconstructor\fR $args $body + } +} + +# Bind the namespace into a (very simple) metaclass for use +oo::class create exprclass { + \fBsuperclass\fR oo::class + \fBdefinitionnamespace\fR myDefinitions +} + +# Use the custom definitions +exprclass create quadratic { + parameters a b c + exprmethod evaluate {x} { + ($a * $x**2) + ($b * $x) + $c + } +} + +# Showing the resulting class and object in action +quadratic create quad 1 2 3 +for {set x 0} {$x <= 4} {incr x} { + puts [format "quad(%d) = %.2f" $x [quad evaluate $x]] +} + \fI\(-> quad(0) = 3.00\fR + \fI\(-> quad(1) = 6.00\fR + \fI\(-> quad(2) = 11.00\fR + \fI\(-> quad(3) = 18.00\fR + \fI\(-> quad(4) = 27.00\fR +.CE +.VE TIP524 .SH "SEE ALSO" next(n), oo::class(n), oo::object(n) .SH KEYWORDS diff --git a/doc/info.n b/doc/info.n index 5732a13..cf5a438 100644 --- a/doc/info.n +++ b/doc/info.n @@ -481,6 +481,24 @@ list; the first element is the list of arguments to the method in a form suitable for passing to another call to \fBproc\fR or a method definition, and the second element is the body of the method. .TP +\fBinfo class definitionnamespace\fI class\fR ?\fIkind\fR? +.VS TIP524 +This subcommand returns the definition namespace for \fIkind\fR definitions of +the class \fIclass\fR; the definition namespace only affects the instances of +\fIclass\fR, not \fIclass\fR itself. The \fIkind\fR can be either +\fB\-class\fR to return the definition namespace used for \fBoo::define\fR, or +\fB\-instance\fR to return the definition namespace used for +\fBoo::objdefine\fR; the \fB\-class\fR kind is default (though this is only +actually useful on classes that are subclasses of \fBoo::class\fR). +.RS +.PP +If \fIclass\fR does not provide a definition namespace of the specified kind, +this command returns the empty string. In those circumstances, the +\fBoo::define\fR and \fBoo::objdefine\fR commands look up which definition +namespace to use using the class inheritance hierarchy. +.RE +.VE TIP524 +.TP \fBinfo class destructor\fI class\fR . This subcommand returns the body of the destructor of class \fIclass\fR. If no -- cgit v0.12 From ccbbac847ad99b9cbb97ff5183f36c862a303bbe Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 29 Oct 2018 12:36:29 +0000 Subject: update changes --- changes | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/changes b/changes index cef7989..aa794ed 100644 --- a/changes +++ b/changes @@ -8881,6 +8881,9 @@ improvements to regexp engine from Postgres (lane,porter,fellows,seltenreich) 2018-10-04 (bug) Prevent crash from NULL keyName (nijtmans) => registry 1.3.3 -2018-10-18 tzdata updated to Olson's tzdata2017f (jima) +2018-10-26 (enhance) advance dde version (nijtmans) +=> dde 1.4.1 -- Released 8.6.9, October 31, 2018 - http://core.tcl-lang.org/tcl/ for details - +2018-10-27 tzdata updated to Olson's tzdata2017g (jima) + +- Released 8.6.9, November 9, 2018 - http://core.tcl-lang.org/tcl/ for details - -- cgit v0.12 From b3291aebaa8427939c47a1cddcbf8091e0b795ec Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 29 Oct 2018 13:36:10 +0000 Subject: [TIP 525] Revise [tcltest::runAllTests] to return indicator of any failure. --- library/tcltest/tcltest.tcl | 4 ++-- tests/all.tcl | 4 +++- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index c90d726..410aa24 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -2741,7 +2741,7 @@ proc tcltest::GetMatchingDirectories {rootdir} { # shell being tested # # Results: -# None. +# Whether there were any failures. # # Side effects: # None. @@ -2887,7 +2887,7 @@ proc tcltest::runAllTests { {shell ""} } { puts [outputChannel] "" puts [outputChannel] [string repeat ~ 44] } - return + return [info exists testFileFailures] } ##################################################################### diff --git a/tests/all.tcl b/tests/all.tcl index e14bd9c..89a4f1a 100644 --- a/tests/all.tcl +++ b/tests/all.tcl @@ -22,5 +22,7 @@ if {[singleProcess]} { interp debug {} -frame 1 } -runAllTests +set ErrorOnFailures [info exists env(ERROR_ON_FAILURES)] +unset -nocomplain env(ERROR_ON_FAILURES) +if {[runAllTests] && $ErrorOnFailures} {exit 1} proc exit args {} -- cgit v0.12 From 2f4c1aecdb5225114428f32eaaf44973983ca89b Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 29 Oct 2018 14:00:48 +0000 Subject: [TIP 525] Backport package tcltest 2.5 --- doc/tcltest.n | 569 +++++++++++++++++++++++++++---------------- library/tcltest/pkgIndex.tcl | 4 +- library/tcltest/tcltest.tcl | 127 ++++++---- tests/tcltest.test | 56 +++-- unix/Makefile.in | 4 +- win/Makefile.in | 4 +- win/makefile.bc | 8 +- 7 files changed, 483 insertions(+), 289 deletions(-) diff --git a/doc/tcltest.n b/doc/tcltest.n index 399a673..b161a2b 100644 --- a/doc/tcltest.n +++ b/doc/tcltest.n @@ -7,8 +7,8 @@ '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" -.TH "tcltest" n 2.3 tcltest "Tcl Bundled Packages" +'\" +.TH "tcltest" n 2.5 tcltest "Tcl Bundled Packages" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! @@ -16,52 +16,52 @@ tcltest \- Test harness support code and utilities .SH SYNOPSIS .nf -\fBpackage require tcltest ?2.3?\fR -.sp -\fBtcltest::test \fIname description ?option value ...?\fR -\fBtcltest::test \fIname description ?constraints? body result\fR -.sp +\fBpackage require tcltest\fR ?\fB2.5\fR? + +\fBtcltest::test \fIname description\fR ?\fI\-option value ...\fR? +\fBtcltest::test \fIname description\fR ?\fIconstraints\fR? \fIbody result\fR + \fBtcltest::loadTestedCommands\fR -\fBtcltest::makeDirectory \fIname ?directory?\fR -\fBtcltest::removeDirectory \fIname ?directory?\fR -\fBtcltest::makeFile \fIcontents name ?directory?\fR -\fBtcltest::removeFile \fIname ?directory?\fR -\fBtcltest::viewFile \fIname ?directory?\fR -\fBtcltest::cleanupTests \fI?runningMultipleTests?\fR +\fBtcltest::makeDirectory \fIname\fR ?\fIdirectory\fR? +\fBtcltest::removeDirectory \fIname\fR ?\fIdirectory\fR? +\fBtcltest::makeFile \fIcontents name\fR ?\fIdirectory\fR? +\fBtcltest::removeFile \fIname\fR ?\fIdirectory\fR? +\fBtcltest::viewFile \fIname\fR ?\fIdirectory\fR? +\fBtcltest::cleanupTests \fR?\fIrunningMultipleTests\fR? \fBtcltest::runAllTests\fR -.sp + \fBtcltest::configure\fR -\fBtcltest::configure \fIoption\fR -\fBtcltest::configure \fIoption value ?option value ...?\fR +\fBtcltest::configure \fI\-option\fR +\fBtcltest::configure \fI\-option value\fR ?\fI\-option value ...\fR? \fBtcltest::customMatch \fImode command\fR -\fBtcltest::testConstraint \fIconstraint ?value?\fR -\fBtcltest::outputChannel \fI?channelID?\fR -\fBtcltest::errorChannel \fI?channelID?\fR -\fBtcltest::interpreter \fI?interp?\fR -.sp -\fBtcltest::debug \fI?level?\fR -\fBtcltest::errorFile \fI?filename?\fR -\fBtcltest::limitConstraints \fI?boolean?\fR -\fBtcltest::loadFile \fI?filename?\fR -\fBtcltest::loadScript \fI?script?\fR -\fBtcltest::match \fI?patternList?\fR -\fBtcltest::matchDirectories \fI?patternList?\fR -\fBtcltest::matchFiles \fI?patternList?\fR -\fBtcltest::outputFile \fI?filename?\fR -\fBtcltest::preserveCore \fI?level?\fR -\fBtcltest::singleProcess \fI?boolean?\fR -\fBtcltest::skip \fI?patternList?\fR -\fBtcltest::skipDirectories \fI?patternList?\fR -\fBtcltest::skipFiles \fI?patternList?\fR -\fBtcltest::temporaryDirectory \fI?directory?\fR -\fBtcltest::testsDirectory \fI?directory?\fR -\fBtcltest::verbose \fI?level?\fR -.sp +\fBtcltest::testConstraint \fIconstraint\fR ?\fIvalue\fR? +\fBtcltest::outputChannel \fR?\fIchannelID\fR? +\fBtcltest::errorChannel \fR?\fIchannelID\fR? +\fBtcltest::interpreter \fR?\fIinterp\fR? + +\fBtcltest::debug \fR?\fIlevel\fR? +\fBtcltest::errorFile \fR?\fIfilename\fR? +\fBtcltest::limitConstraints \fR?\fIboolean\fR? +\fBtcltest::loadFile \fR?\fIfilename\fR? +\fBtcltest::loadScript \fR?\fIscript\fR? +\fBtcltest::match \fR?\fIpatternList\fR? +\fBtcltest::matchDirectories \fR?\fIpatternList\fR? +\fBtcltest::matchFiles \fR?\fIpatternList\fR? +\fBtcltest::outputFile \fR?\fIfilename\fR? +\fBtcltest::preserveCore \fR?\fIlevel\fR? +\fBtcltest::singleProcess \fR?\fIboolean\fR? +\fBtcltest::skip \fR?\fIpatternList\fR? +\fBtcltest::skipDirectories \fR?\fIpatternList\fR? +\fBtcltest::skipFiles \fR?\fIpatternList\fR? +\fBtcltest::temporaryDirectory \fR?\fIdirectory\fR? +\fBtcltest::testsDirectory \fR?\fIdirectory\fR? +\fBtcltest::verbose \fR?\fIlevel\fR? + \fBtcltest::test \fIname description optionList\fR \fBtcltest::bytestring \fIstring\fR \fBtcltest::normalizeMsg \fImsg\fR \fBtcltest::normalizePath \fIpathVar\fR -\fBtcltest::workingDirectory \fI?dir?\fR +\fBtcltest::workingDirectory \fR?\fIdir\fR? .fi .BE .SH DESCRIPTION @@ -90,7 +90,8 @@ of how to use the commands of \fBtcltest\fR to produce test suites for your Tcl-enabled code. .SH COMMANDS .TP -\fBtest\fR \fIname description ?option value ...?\fR +\fBtest\fR \fIname description\fR ?\fI\-option value ...\fR? +. Defines and possibly runs a test with the name \fIname\fR and description \fIdescription\fR. The name and description of a test are used in messages reported by \fBtest\fR during the @@ -103,7 +104,8 @@ See \fBTESTS\fR below for a complete description of the valid options and how they define a test. The \fBtest\fR command returns an empty string. .TP -\fBtest\fR \fIname description ?constraints? body result\fR +\fBtest\fR \fIname description\fR ?\fIconstraints\fR? \fIbody result\fR +. This form of \fBtest\fR is provided to support test suites written for version 1 of the \fBtcltest\fR package, and also a simpler interface for a common usage. It is the same as @@ -115,14 +117,16 @@ all \fIoption\fRs begin with .QW \- . .TP \fBloadTestedCommands\fR -Evaluates in the caller's context the script specified by +. +Evaluates in the caller's context the script specified by \fBconfigure \-load\fR or \fBconfigure \-loadfile\fR. Returns the result of that script evaluation, including any error raised by the script. Use this command and the related configuration options to provide the commands to be tested to the interpreter running the test suite. .TP -\fBmakeFile\fR \fIcontents name ?directory?\fR +\fBmakeFile\fR \fIcontents name\fR ?\fIdirectory\fR? +. Creates a file named \fIname\fR relative to directory \fIdirectory\fR and write \fIcontents\fR to that file using the encoding \fBencoding system\fR. @@ -137,14 +141,16 @@ of \fBcleanupTests\fR, unless it is removed by Returns the full path of the file created. Use this command to create any text file required by a test with contents as needed. .TP -\fBremoveFile\fR \fIname ?directory?\fR +\fBremoveFile\fR \fIname\fR ?\fIdirectory\fR? +. Forces the file referenced by \fIname\fR to be removed. This file name should be relative to \fIdirectory\fR. The default value of \fIdirectory\fR is the directory \fBconfigure \-tmpdir\fR. Returns an empty string. Use this command to delete files created by \fBmakeFile\fR. .TP -\fBmakeDirectory\fR \fIname ?directory?\fR +\fBmakeDirectory\fR \fIname\fR ?\fIdirectory\fR? +. Creates a directory named \fIname\fR relative to directory \fIdirectory\fR. The directory will be removed by the next evaluation of \fBcleanupTests\fR, unless it is removed by \fBremoveDirectory\fR first. @@ -153,7 +159,8 @@ The default value of \fIdirectory\fR is the directory Returns the full path of the directory created. Use this command to create any directories that are required to exist by a test. .TP -\fBremoveDirectory\fR \fIname ?directory?\fR +\fBremoveDirectory\fR \fIname\fR ?\fIdirectory\fR? +. Forces the directory referenced by \fIname\fR to be removed. This directory should be relative to \fIdirectory\fR. The default value of \fIdirectory\fR is the directory @@ -161,7 +168,8 @@ The default value of \fIdirectory\fR is the directory Returns an empty string. Use this command to delete any directories created by \fBmakeDirectory\fR. .TP -\fBviewFile\fR \fIfile ?directory?\fR +\fBviewFile\fR \fIfile\fR ?\fIdirectory\fR? +. Returns the contents of \fIfile\fR, except for any final newline, just as \fBread \-nonewline\fR would return. This file name should be relative to \fIdirectory\fR. @@ -174,6 +182,7 @@ the system encoding, so its usefulness is limited to text files. .TP \fBcleanupTests\fR +. Intended to clean up and summarize after several tests have been run. Typically called once per test file, at the end of the file after all tests have been completed. For best effectiveness, be @@ -188,28 +197,32 @@ in the directory \fBconfigure \-tmpdir\fR created since the last \fBcleanupTests\fR, but not created by \fBmakeFile\fR or \fBmakeDirectory\fR are printed to \fBoutputChannel\fR. This command also restores the original -shell environment, as described by the \fB::env\fR +shell environment, as described by the global \fBenv\fR array. Returns an empty string. .RE .TP \fBrunAllTests\fR +. This is a master command meant to run an entire suite of tests, spanning multiple files and/or directories, as governed by the configurable options of \fBtcltest\fR. See \fBRUNNING ALL TESTS\fR below for a complete description of the many variations possible with \fBrunAllTests\fR. -.SH "CONFIGURATION COMMANDS" +.SS "CONFIGURATION COMMANDS" .TP \fBconfigure\fR +. Returns the list of configurable options supported by \fBtcltest\fR. See \fBCONFIGURABLE OPTIONS\fR below for the full list of options, their valid values, and their effect on \fBtcltest\fR operations. .TP \fBconfigure \fIoption\fR +. Returns the current value of the supported configurable option \fIoption\fR. Raises an error if \fIoption\fR is not a supported configurable option. .TP -\fBconfigure \fIoption value ?option value ...?\fR +\fBconfigure \fIoption value\fR ?\fI\-option value ...\fR? +. Sets the value of each configurable option \fIoption\fR to the corresponding value \fIvalue\fR, in order. Raises an error if an \fIoption\fR is not a supported configurable option, or if @@ -220,13 +233,14 @@ arguments are not processed. .RS .PP If the environment variable \fB::env(TCLTEST_OPTIONS)\fR exists when -the \fBtcltest\fR package is loaded (by \fBpackage require tcltest\fR) +the \fBtcltest\fR package is loaded (by \fBpackage require\fR \fBtcltest\fR) then its value is taken as a list of arguments to pass to \fBconfigure\fR. This allows the default values of the configuration options to be set by the environment. .RE .TP \fBcustomMatch \fImode script\fR +. Registers \fImode\fR as a new legal value of the \fB\-match\fR option to \fBtest\fR. When the \fB\-match \fImode\fR option is passed to \fBtest\fR, the script \fIscript\fR will be evaluated @@ -239,81 +253,119 @@ The completed script is expected to return a boolean value indicating whether or not the results match. The built-in matching modes of \fBtest\fR are \fBexact\fR, \fBglob\fR, and \fBregexp\fR. .TP -\fBtestConstraint \fIconstraint ?boolean?\fR +\fBtestConstraint \fIconstraint\fR ?\fIboolean\fR? +. Sets or returns the boolean value associated with the named \fIconstraint\fR. See \fBTEST CONSTRAINTS\fR below for more information. .TP -\fBinterpreter\fR \fI?executableName?\fR +\fBinterpreter\fR ?\fIexecutableName\fR? +. Sets or returns the name of the executable to be \fBexec\fRed by \fBrunAllTests\fR to run each test file when \fBconfigure \-singleproc\fR is false. The default value for \fBinterpreter\fR is the name of the currently running program as returned by \fBinfo nameofexecutable\fR. .TP -\fBoutputChannel\fR \fI?channelID?\fR -Sets or returns the output channel ID. This defaults to stdout. +\fBoutputChannel\fR ?\fIchannelID\fR? +. +Sets or returns the output channel ID. This defaults to \fBstdout\fR. Any test that prints test related output should send that output to \fBoutputChannel\fR rather than letting -that output default to stdout. +that output default to \fBstdout\fR. .TP -\fBerrorChannel\fR \fI?channelID?\fR -Sets or returns the error channel ID. This defaults to stderr. +\fBerrorChannel\fR ?\fIchannelID\fR? +. +Sets or returns the error channel ID. This defaults to \fBstderr\fR. Any test that prints error messages should send that output to \fBerrorChannel\fR rather than printing -directly to stderr. -.SH "SHORTCUT COMMANDS" -.TP -\fBdebug \fI?level?\fR -Same as \fBconfigure \-debug \fI?level?\fR. -.TP -\fBerrorFile \fI?filename?\fR -Same as \fBconfigure \-errfile \fI?filename?\fR. -.TP -\fBlimitConstraints \fI?boolean?\fR -Same as \fBconfigure \-limitconstraints \fI?boolean?\fR. -.TP -\fBloadFile \fI?filename?\fR -Same as \fBconfigure \-loadfile \fI?filename?\fR. -.TP -\fBloadScript \fI?script?\fR -Same as \fBconfigure \-load \fI?script?\fR. -.TP -\fBmatch \fI?patternList?\fR -Same as \fBconfigure \-match \fI?patternList?\fR. -.TP -\fBmatchDirectories \fI?patternList?\fR -Same as \fBconfigure \-relateddir \fI?patternList?\fR. -.TP -\fBmatchFiles \fI?patternList?\fR -Same as \fBconfigure \-file \fI?patternList?\fR. -.TP -\fBoutputFile \fI?filename?\fR -Same as \fBconfigure \-outfile \fI?filename?\fR. -.TP -\fBpreserveCore \fI?level?\fR -Same as \fBconfigure \-preservecore \fI?level?\fR. -.TP -\fBsingleProcess \fI?boolean?\fR -Same as \fBconfigure \-singleproc \fI?boolean?\fR. -.TP -\fBskip \fI?patternList?\fR -Same as \fBconfigure \-skip \fI?patternList?\fR. -.TP -\fBskipDirectories \fI?patternList?\fR -Same as \fBconfigure \-asidefromdir \fI?patternList?\fR. -.TP -\fBskipFiles \fI?patternList?\fR -Same as \fBconfigure \-notfile \fI?patternList?\fR. -.TP -\fBtemporaryDirectory \fI?directory?\fR -Same as \fBconfigure \-tmpdir \fI?directory?\fR. -.TP -\fBtestsDirectory \fI?directory?\fR -Same as \fBconfigure \-testdir \fI?directory?\fR. -.TP -\fBverbose \fI?level?\fR -Same as \fBconfigure \-verbose \fI?level?\fR. -.SH "OTHER COMMANDS" +directly to \fBstderr\fR. +.SS "SHORTCUT CONFIGURATION COMMANDS" +.TP +\fBdebug\fR ?\fIlevel\fR? +. +Same as +.QW "\fBconfigure \-debug\fR ?\fIlevel\fR?" . +.TP +\fBerrorFile\fR ?\fIfilename\fR? +. +Same as +.QW "\fBconfigure \-errfile\fR ?\fIfilename\fR?" . +.TP +\fBlimitConstraints\fR ?\fIboolean\fR? +. +Same as +.QW "\fBconfigure \-limitconstraints\fR ?\fIboolean\fR?" . +.TP +\fBloadFile\fR ?\fIfilename\fR? +. +Same as +.QW "\fBconfigure \-loadfile\fR ?\fIfilename\fR?" . +.TP +\fBloadScript\fR ?\fIscript\fR? +. +Same as +.QW "\fBconfigure \-load\fR ?\fIscript\fR?" . +.TP +\fBmatch\fR ?\fIpatternList\fR? +. +Same as +.QW "\fBconfigure \-match\fR ?\fIpatternList\fR?" . +.TP +\fBmatchDirectories\fR ?\fIpatternList\fR? +. +Same as +.QW "\fBconfigure \-relateddir\fR ?\fIpatternList\fR?" . +.TP +\fBmatchFiles\fR ?\fIpatternList\fR? +. +Same as +.QW "\fBconfigure \-file\fR ?\fIpatternList\fR?" . +.TP +\fBoutputFile\fR ?\fIfilename\fR? +. +Same as +.QW "\fBconfigure \-outfile\fR ?\fIfilename\fR?" . +.TP +\fBpreserveCore\fR ?\fIlevel\fR? +. +Same as +.QW "\fBconfigure \-preservecore\fR ?\fIlevel\fR?" . +.TP +\fBsingleProcess\fR ?\fIboolean\fR? +. +Same as +.QW "\fBconfigure \-singleproc\fR ?\fIboolean\fR?" . +.TP +\fBskip\fR ?\fIpatternList\fR? +. +Same as +.QW "\fBconfigure \-skip\fR ?\fIpatternList\fR?" . +.TP +\fBskipDirectories\fR ?\fIpatternList\fR? +. +Same as +.QW "\fBconfigure \-asidefromdir\fR ?\fIpatternList\fR?" . +.TP +\fBskipFiles\fR ?\fIpatternList\fR? +. +Same as +.QW "\fBconfigure \-notfile\fR ?\fIpatternList\fR?" . +.TP +\fBtemporaryDirectory\fR ?\fIdirectory\fR? +. +Same as +.QW "\fBconfigure \-tmpdir\fR ?\fIdirectory\fR?" . +.TP +\fBtestsDirectory\fR ?\fIdirectory\fR? +. +Same as +.QW "\fBconfigure \-testdir\fR ?\fIdirectory\fR?" . +.TP +\fBverbose\fR ?\fIlevel\fR? +. +Same as +.QW "\fBconfigure \-verbose\fR ?\fIlevel\fR?" . +.SS "OTHER COMMANDS" .PP The remaining commands provided by \fBtcltest\fR have better alternatives provided by \fBtcltest\fR or \fBTcl\fR itself. They @@ -321,6 +373,7 @@ are retained to support existing test suites, but should be avoided in new code. .TP \fBtest\fR \fIname description optionList\fR +. This form of \fBtest\fR was provided to enable passing many options spanning several lines to \fBtest\fR as a single argument quoted by braces, rather than needing to backslash quote @@ -344,13 +397,15 @@ the source code of \fBtcltest\fR if you want to know the substitution details, or just enclose the third through last argument to \fBtest\fR in braces and hope for the best. .TP -\fBworkingDirectory\fR \fI?directoryName?\fR +\fBworkingDirectory\fR ?\fIdirectoryName\fR? +. Sets or returns the current working directory when the test suite is running. The default value for workingDirectory is the directory in which the test suite was launched. The Tcl commands \fBcd\fR and \fBpwd\fR are sufficient replacements. .TP -\fBnormalizeMsg\fR \fImsg\fR +\fBnormalizeMsg \fImsg\fR +. Returns the result of removing the .QW extra newlines from \fImsg\fR, where @@ -360,20 +415,23 @@ processing commands to modify strings as you wish, and \fBcustomMatch\fR allows flexible matching of actual and expected results. .TP -\fBnormalizePath\fR \fIpathVar\fR +\fBnormalizePath \fIpathVar\fR +. Resolves symlinks in a path, thus creating a path without internal redirection. It is assumed that \fIpathVar\fR is absolute. \fIpathVar\fR is modified in place. The Tcl command \fBfile normalize\fR is a sufficient replacement. .TP -\fBbytestring\fR \fIstring\fR +\fBbytestring \fIstring\fR +. Construct a string that consists of the requested sequence of bytes, as opposed to a string of properly formed UTF-8 characters using the value supplied in \fIstring\fR. This allows the tester to create denormalized or improperly formed strings to pass to C procedures that are supposed to accept strings with embedded NULL types and confirm that a string result has a certain pattern of bytes. This is -exactly equivalent to the Tcl command \fBencoding convertfrom identity\fR. +exactly equivalent to the Tcl command \fBencoding convertfrom\fR +\fBidentity\fR. .SH TESTS .PP The \fBtest\fR command is the heart of the \fBtcltest\fR package. @@ -388,15 +446,16 @@ The valid options for \fBtest\fR are summarized: .PP .CS \fBtest\fR \fIname\fR \fIdescription\fR - ?-constraints \fIkeywordList|expression\fR? - ?-setup \fIsetupScript\fR? - ?-body \fItestScript\fR? - ?-cleanup \fIcleanupScript\fR? - ?-result \fIexpectedAnswer\fR? - ?-output \fIexpectedOutput\fR? - ?-errorOutput \fIexpectedError\fR? - ?-returnCodes \fIcodeList\fR? - ?-match \fImode\fR? + ?\fB\-constraints \fIkeywordList|expression\fR? + ?\fB\-setup \fIsetupScript\fR? + ?\fB\-body \fItestScript\fR? + ?\fB\-cleanup \fIcleanupScript\fR? + ?\fB\-result \fIexpectedAnswer\fR? + ?\fB\-output \fIexpectedOutput\fR? + ?\fB\-errorOutput \fIexpectedError\fR? + ?\fB\-returnCodes \fIcodeList\fR? + ?\fB\-errorCode \fIexpectedErrorCode\fR? + ?\fB\-match \fImode\fR? .CE .PP The \fIname\fR may be any string. It is conventional to choose @@ -428,11 +487,12 @@ test, typically test failure messages. Good \fIdescription\fR values should briefly explain the purpose of the test to users of a test suite. The name of a Tcl or C function being tested should be included in the description for regression tests. If the test case exists to reproduce -a bug, include the bug ID in the description. +a bug, include the bug ID in the description. .PP Valid attributes and associated values are: .TP -\fB\-constraints \fIkeywordList|expression\fR +\fB\-constraints \fIkeywordList\fR|\fIexpression\fR +. The optional \fB\-constraints\fR attribute can be list of one or more keywords or an expression. If the \fB\-constraints\fR value is a list of keywords, each of these keywords should be the name of a constraint @@ -449,29 +509,35 @@ should be accomplished by the \fB\-constraints\fR option, not by conditional evaluation of \fBtest\fR. In that way, the same number of tests are always reported by the test suite, though the number skipped may change based on the testing environment. -The default value is an empty list. -See \fBTEST CONSTRAINTS\fR below for a list of built-in constraints +The default value is an empty list. +See \fBTEST CONSTRAINTS\fR below for a list of built-in constraints and information on how to add your own constraints. .TP \fB\-setup \fIscript\fR +. The optional \fB\-setup\fR attribute indicates a \fIscript\fR that will be run before the script indicated by the \fB\-body\fR attribute. If evaluation of \fIscript\fR raises an error, the test will fail. The default value is an empty script. .TP \fB\-body \fIscript\fR -The \fB\-body\fR attribute indicates the \fIscript\fR to run to carry out the -test. It must return a result that can be checked for correctness. -If evaluation of \fIscript\fR raises an error, the test will fail. +. +The \fB\-body\fR attribute indicates the \fIscript\fR to run to carry out the +test, which must return a result that can be checked for correctness. +If evaluation of \fIscript\fR raises an error, the test will fail +(unless the \fB\-returnCodes\fR option is used to state that an error +is expected). The default value is an empty script. .TP \fB\-cleanup \fIscript\fR +. The optional \fB\-cleanup\fR attribute indicates a \fIscript\fR that will be run after the script indicated by the \fB\-body\fR attribute. If evaluation of \fIscript\fR raises an error, the test will fail. The default value is an empty script. .TP \fB\-match \fImode\fR +. The \fB\-match\fR attribute determines how expected answers supplied by \fB\-result\fR, \fB\-output\fR, and \fB\-errorOutput\fR are compared. Valid values for \fImode\fR are \fBregexp\fR, \fBglob\fR, \fBexact\fR, and @@ -479,27 +545,31 @@ any value registered by a prior call to \fBcustomMatch\fR. The default value is \fBexact\fR. .TP \fB\-result \fIexpectedValue\fR +. The \fB\-result\fR attribute supplies the \fIexpectedValue\fR against which the return value from script will be compared. The default value is an empty string. .TP \fB\-output \fIexpectedValue\fR +. The \fB\-output\fR attribute supplies the \fIexpectedValue\fR against which any output sent to \fBstdout\fR or \fBoutputChannel\fR during evaluation of the script(s) will be compared. Note that only output printed using -\fB::puts\fR is used for comparison. If \fB\-output\fR is not specified, -output sent to \fBstdout\fR and \fBoutputChannel\fR is not processed for -comparison. +the global \fBputs\fR command is used for comparison. If \fB\-output\fR is +not specified, output sent to \fBstdout\fR and \fBoutputChannel\fR is not +processed for comparison. .TP \fB\-errorOutput \fIexpectedValue\fR +. The \fB\-errorOutput\fR attribute supplies the \fIexpectedValue\fR against -which any output sent to \fBstderr\fR or \fBerrorChannel\fR during +which any output sent to \fBstderr\fR or \fBerrorChannel\fR during evaluation of the script(s) will be compared. Note that only output -printed using \fB::puts\fR is used for comparison. If \fB\-errorOutput\fR -is not specified, output sent to \fBstderr\fR and \fBerrorChannel\fR is -not processed for comparison. +printed using the global \fBputs\fR command is used for comparison. If +\fB\-errorOutput\fR is not specified, output sent to \fBstderr\fR and +\fBerrorChannel\fR is not processed for comparison. .TP \fB\-returnCodes \fIexpectedCodeList\fR +. The optional \fB\-returnCodes\fR attribute supplies \fIexpectedCodeList\fR, a list of return codes that may be accepted from evaluation of the \fB\-body\fR script. If evaluation of the \fB\-body\fR script returns @@ -507,7 +577,16 @@ a code not in the \fIexpectedCodeList\fR, the test fails. All return codes known to \fBreturn\fR, in both numeric and symbolic form, including extended return codes, are acceptable elements in the \fIexpectedCodeList\fR. Default value is -.QW \fBok return\fR. +.QW "\fBok return\fR" . +.TP +\fB\-errorCode \fIexpectedErrorCode\fR +. +The optional \fB\-errorCode\fR attribute supplies \fIexpectedErrorCode\fR, +a glob pattern that should match the error code reported from evaluation of the +\fB\-body\fR script. If evaluation of the \fB\-body\fR script returns +a code not matching \fIexpectedErrorCode\fR, the test fails. Default value is +.QW "\fB*\fR" . +If \fB\-returnCodes\fR does not include \fBerror\fR it is set to \fBerror\fR. .PP To pass, a test must successfully evaluate its \fB\-setup\fR, \fB\-body\fR, and \fB\-cleanup\fR scripts. The return code of the \fB\-body\fR script and @@ -524,12 +603,12 @@ In default operation, a successful test produces no output. The output messages produced by \fBtest\fR are controlled by the \fBconfigure \-verbose\fR option as described in \fBCONFIGURABLE OPTIONS\fR below. Any output produced by the test scripts themselves should be -produced using \fB::puts\fR to \fBoutputChannel\fR or +produced using \fBputs\fR to \fBoutputChannel\fR or \fBerrorChannel\fR, so that users of the test suite may easily capture output with the \fBconfigure \-outfile\fR and \fBconfigure \-errfile\fR options, and so that the \fB\-output\fR and \fB\-errorOutput\fR attributes work properly. -.SH "TEST CONSTRAINTS" +.SS "TEST CONSTRAINTS" .PP Constraints are used to determine whether or not a test should be skipped. Each constraint has a name, which may be any string, and a boolean @@ -557,112 +636,133 @@ The following is a list of constraints pre-defined by the \fBtcltest\fR package itself: .TP \fIsingleTestInterp\fR -test can only be run if all test files are sourced into a single interpreter +. +This test can only be run if all test files are sourced into a single +interpreter. .TP \fIunix\fR -test can only be run on any Unix platform +. +This test can only be run on any Unix platform. .TP \fIwin\fR -test can only be run on any Windows platform +. +This test can only be run on any Windows platform. .TP \fInt\fR -test can only be run on any Windows NT platform -.TP -\fI95\fR -test can only be run on any Windows 95 platform -.TP -\fI98\fR -test can only be run on any Windows 98 platform +. +This test can only be run on any Windows NT platform. .TP \fImac\fR -test can only be run on any Mac platform +. +This test can only be run on any Mac platform. .TP \fIunixOrWin\fR -test can only be run on a Unix or Windows platform +. +This test can only be run on a Unix or Windows platform. .TP \fImacOrWin\fR -test can only be run on a Mac or Windows platform +. +This test can only be run on a Mac or Windows platform. .TP \fImacOrUnix\fR -test can only be run on a Mac or Unix platform +. +This test can only be run on a Mac or Unix platform. .TP \fItempNotWin\fR -test can not be run on Windows. This flag is used to temporarily -disable a test. +. +This test can not be run on Windows. This flag is used to temporarily +disable a test. .TP \fItempNotMac\fR -test can not be run on a Mac. This flag is used +. +This test can not be run on a Mac. This flag is used to temporarily disable a test. .TP \fIunixCrash\fR -test crashes if it is run on Unix. This flag is used to temporarily -disable a test. +. +This test crashes if it is run on Unix. This flag is used to temporarily +disable a test. .TP \fIwinCrash\fR -test crashes if it is run on Windows. This flag is used to temporarily -disable a test. +. +This test crashes if it is run on Windows. This flag is used to temporarily +disable a test. .TP \fImacCrash\fR -test crashes if it is run on a Mac. This flag is used to temporarily -disable a test. +. +This test crashes if it is run on a Mac. This flag is used to temporarily +disable a test. .TP \fIemptyTest\fR -test is empty, and so not worth running, but it remains as a +. +This test is empty, and so not worth running, but it remains as a place-holder for a test to be written in the future. This constraint has value false to cause tests to be skipped unless the user specifies otherwise. .TP \fIknownBug\fR -test is known to fail and the bug is not yet fixed. This constraint +. +This test is known to fail and the bug is not yet fixed. This constraint has value false to cause tests to be skipped unless the user specifies otherwise. .TP \fInonPortable\fR -test can only be run in some known development environment. +. +This test can only be run in some known development environment. Some tests are inherently non-portable because they depend on things like word length, file system configuration, window manager, etc. This constraint has value false to cause tests to be skipped unless -the user specifies otherwise. +the user specifies otherwise. .TP \fIuserInteraction\fR -test requires interaction from the user. This constraint has +. +This test requires interaction from the user. This constraint has value false to causes tests to be skipped unless the user specifies -otherwise. +otherwise. .TP \fIinteractive\fR -test can only be run in if the interpreter is in interactive mode +. +This test can only be run in if the interpreter is in interactive mode (when the global tcl_interactive variable is set to 1). .TP \fInonBlockFiles\fR -test can only be run if platform supports setting files into -nonblocking mode +. +This test can only be run if platform supports setting files into +nonblocking mode. .TP \fIasyncPipeClose\fR -test can only be run if platform supports async flush and async close -on a pipe +. +This test can only be run if platform supports async flush and async close +on a pipe. .TP \fIunixExecs\fR -test can only be run if this machine has Unix-style commands +. +This test can only be run if this machine has Unix-style commands \fBcat\fR, \fBecho\fR, \fBsh\fR, \fBwc\fR, \fBrm\fR, \fBsleep\fR, -\fBfgrep\fR, \fBps\fR, \fBchmod\fR, and \fBmkdir\fR available +\fBfgrep\fR, \fBps\fR, \fBchmod\fR, and \fBmkdir\fR available. .TP \fIhasIsoLocale\fR -test can only be run if can switch to an ISO locale +. +This test can only be run if can switch to an ISO locale. .TP \fIroot\fR -test can only run if Unix user is root +. +This test can only run if Unix user is root. .TP \fInotRoot\fR -test can only run if Unix user is not root +. +This test can only run if Unix user is not root. .TP \fIeformat\fR -test can only run if app has a working version of sprintf with respect +. +This test can only run if app has a working version of sprintf with respect to the .QW e format of floating-point numbers. .TP \fIstdio\fR -test can only be run if \fBinterpreter\fR can be \fBopen\fRed +. +This test can only be run if \fBinterpreter\fR can be \fBopen\fRed as a pipe. .PP The alternative mode of constraint control is enabled by setting @@ -685,7 +785,7 @@ up a configuration with .PP to run exactly those tests that exercise known bugs, and discover whether any of them pass, indicating the bug had been fixed. -.SH "RUNNING ALL TESTS" +.SS "RUNNING ALL TESTS" .PP The single command \fBrunAllTests\fR is evaluated to run an entire test suite, spanning many files and directories. The configuration @@ -702,7 +802,7 @@ and sorted. Then each file will be evaluated in turn. If be \fBsource\fRd in the caller's context. If it is false, then a copy of \fBinterpreter\fR will be \fBexec\fR'd to evaluate each file. The multi-process operation is useful -when testing can cause errors so severe that a process +when testing can cause errors so severe that a process terminates. Although such an error may terminate a child process evaluating one file, the master process can continue with the rest of the test suite. In multi-process operation, @@ -748,17 +848,19 @@ The \fBconfigure\fR command is used to set and query the configurable options of \fBtcltest\fR. The valid options are: .TP \fB\-singleproc \fIboolean\fR +. Controls whether or not \fBrunAllTests\fR spawns a child process for each test file. No spawning when \fIboolean\fR is true. Default value is false. .TP \fB\-debug \fIlevel\fR +. Sets the debug level to \fIlevel\fR, an integer value indicating how -much debugging information should be printed to stdout. Note that -debug messages always go to stdout, independent of the value of +much debugging information should be printed to \fBstdout\fR. Note that +debug messages always go to \fBstdout\fR, independent of the value of \fBconfigure \-outfile\fR. Default value is 0. Levels are defined as: .RS -.IP 0 +.IP 0 4 Do not display any debug information. .IP 1 Display information regarding whether a test is skipped because it @@ -769,41 +871,55 @@ print warnings about possible lack of cleanup or balance in test files. Also print warnings about any re-use of test names. .IP 2 Display the flag array parsed by the command line processor, the -contents of the ::env array, and all user-defined variables that exist -in the current namespace as they are used. +contents of the global \fBenv\fR array, and all user-defined variables +that exist in the current namespace as they are used. .IP 3 Display information regarding what individual procs in the test harness are doing. .RE .TP \fB\-verbose \fIlevel\fR +. Sets the type of output verbosity desired to \fIlevel\fR, a list of zero or more of the elements \fBbody\fR, \fBpass\fR, -\fBskip\fR, \fBstart\fR, \fBerror\fR and \fBline\fR. Default value -is \fB{body error}\fR. -Levels are defined as: +\fBskip\fR, \fBstart\fR, \fBerror\fR, \fBline\fR, \fBmsec\fR and \fBusec\fR. +Default value is +.QW "\fBbody error\fR" . +Levels are defined as: .RS -.IP "body (b)" +.IP "body (\fBb\fR)" Display the body of failed tests -.IP "pass (p)" +.IP "pass (\fBp\fR)" Print output when a test passes -.IP "skip (s)" +.IP "skip (\fBs\fR)" Print output when a test is skipped -.IP "start (t)" +.IP "start (\fBt\fR)" Print output whenever a test starts -.IP "error (e)" +.IP "error (\fBe\fR)" Print errorInfo and errorCode, if they exist, when a test return code does not match its expected return code -.IP "line (l)" +.IP "line (\fBl\fR)" Print source file line information of failed tests -.RE +.IP "msec (\fBm\fR)" +Print each test's execution time in milliseconds +.IP "usec (\fBu\fR)" +Print each test's execution time in microseconds +.PP +Note that the \fBmsec\fR and \fBusec\fR verbosity levels are provided as +indicative measures only. They do not tackle the problem of repeatibility which +should be considered in performance tests or benchmarks. To use these verbosity +levels to thoroughly track performance degradations, consider wrapping your +test bodies with \fBtime\fR commands. +.PP The single letter abbreviations noted above are also recognized so that .QW "\fBconfigure \-verbose pt\fR" is the same as .QW "\fBconfigure \-verbose {pass start}\fR" . +.RE .TP \fB\-preservecore \fIlevel\fR +. Sets the core preservation level to \fIlevel\fR. This level determines how stringent checks for core files are. Default value is 0. Levels are defined as: @@ -815,21 +931,24 @@ test files have been evaluated. .IP 1 Also check for core files at the end of each \fBtest\fR command. .IP 2 -Check for core files at all times described above, and save a +Check for core files at all times described above, and save a copy of each core file produced in \fBconfigure \-tmpdir\fR. .RE .TP \fB\-limitconstraints \fIboolean\fR +. Sets the mode by which \fBtest\fR honors constraints as described in \fBTESTS\fR above. Default value is false. .TP \fB\-constraints \fIlist\fR +. Sets all the constraints in \fIlist\fR to true. Also used in combination with \fBconfigure \-limitconstraints true\fR to control an alternative constraint mode as described in \fBTESTS\fR above. Default value is an empty list. .TP \fB\-tmpdir \fIdirectory\fR +. Sets the temporary directory to be used by \fBmakeFile\fR, \fBmakeDirectory\fR, \fBviewFile\fR, \fBremoveFile\fR, and \fBremoveDirectory\fR as the default directory where @@ -837,55 +956,66 @@ temporary files and directories created by test files should be created. Default value is \fBworkingDirectory\fR. .TP \fB\-testdir \fIdirectory\fR +. Sets the directory searched by \fBrunAllTests\fR for test files and subdirectories. Default value is \fBworkingDirectory\fR. .TP \fB\-file \fIpatternList\fR +. Sets the list of patterns used by \fBrunAllTests\fR to determine what test files to evaluate. Default value is .QW \fB*.test\fR . .TP \fB\-notfile \fIpatternList\fR +. Sets the list of patterns used by \fBrunAllTests\fR to determine what test files to skip. Default value is .QW \fBl.*.test\fR , so that any SCCS lock files are skipped. .TP \fB\-relateddir \fIpatternList\fR +. Sets the list of patterns used by \fBrunAllTests\fR to determine what subdirectories to search for an \fBall.tcl\fR file. Default value is .QW \fB*\fR . .TP \fB\-asidefromdir \fIpatternList\fR +. Sets the list of patterns used by \fBrunAllTests\fR to determine what subdirectories to skip when searching for an \fBall.tcl\fR file. Default value is an empty list. .TP \fB\-match \fIpatternList\fR +. Set the list of patterns used by \fBtest\fR to determine whether a test should be run. Default value is .QW \fB*\fR . .TP \fB\-skip \fIpatternList\fR +. Set the list of patterns used by \fBtest\fR to determine whether a test should be skipped. Default value is an empty list. .TP \fB\-load \fIscript\fR +. Sets a script to be evaluated by \fBloadTestedCommands\fR. Default value is an empty script. .TP \fB\-loadfile \fIfilename\fR +. Sets the filename from which to read a script to be evaluated by \fBloadTestedCommands\fR. This is an alternative to \fB\-load\fR. They cannot be used together. .TP -\fB\-outfile \fIfilename\fR +\fB\-outfile \fIfilename\fR +. Sets the file to which all output produced by tcltest should be written. A file named \fIfilename\fR will be \fBopen\fRed for writing, and the resulting channel will be set as the value of \fBoutputChannel\fR. .TP \fB\-errfile \fIfilename\fR +. Sets the file to which all error output produced by tcltest should be written. A file named \fIfilename\fR will be \fBopen\fRed for writing, and the resulting channel will be set as the value @@ -948,12 +1078,14 @@ Test with a constraint. .PP At the next higher layer of organization, several \fBtest\fR commands are gathered together into a single test file. Test files should have -names with the \fB.test\fR extension, because that is the default pattern +names with the +.QW \fB.test\fR +extension, because that is the default pattern used by \fBrunAllTests\fR to find test files. It is a good rule of thumb to have one test file for each source code file of your project. It is good practice to edit the test file and the source code file together, keeping tests synchronized with code changes. -.PP +.PP Most of the code in the test file should be the \fBtest\fR commands. Use constraints to skip tests, rather than conditional evaluation of \fBtest\fR. @@ -976,7 +1108,7 @@ guard: .PP .CS if $myRequirement { - test badConditionalTest {} { + \fBtest\fR badConditionalTest {} { #body } result } @@ -1066,7 +1198,7 @@ to continue to support existing test suites written to the older interface specifications, many of those deprecated commands and variables still work as before. For example, in many circumstances, \fBconfigure\fR will be automatically called shortly after -\fBpackage require tcltest 2.1\fR succeeds with arguments +\fBpackage require\fR \fBtcltest 2.1\fR succeeds with arguments from the variable \fB::argv\fR. This is to support test suites that depend on the old behavior that \fBtcltest\fR was automatically configured from command line arguments. New test files should not @@ -1076,12 +1208,18 @@ depend on this, but should explicitly include eval \fB::tcltest::configure\fR $::argv .CE .PP +or +.PP +.CS +\fB::tcltest::configure\fR {*}$::argv +.CE +.PP to establish a configuration from command line arguments. .SH "KNOWN ISSUES" There are two known issues related to nested evaluations of \fBtest\fR. The first issue relates to the stack level in which test scripts are executed. Tests nested within other tests may be executed at the same -stack level as the outermost test. For example, in the following code: +stack level as the outermost test. For example, in the following code: .PP .CS \fBtest\fR level-1.1 {level 1} { @@ -1093,7 +1231,7 @@ stack level as the outermost test. For example, in the following code: .CE .PP any script executed in level-2.1 may be executed at the same stack -level as the script defined for level-1.1. +level as the script defined for level-1.1. .PP In addition, while two \fBtest\fRs have been run, results will only be reported by \fBcleanupTests\fR for tests at the same level as @@ -1117,12 +1255,15 @@ and refer to tests that were run at the same test level as test level-1.1. .PP Implementation of output and error comparison in the test command -depends on usage of ::puts in your application code. Output is -intercepted by redefining the ::puts command while the defined test +depends on usage of \fBputs\fR in your application code. Output is +intercepted by redefining the global \fBputs\fR command while the defined test script is being run. Errors thrown by C procedures or printed -directly from C applications will not be caught by the test command. +directly from C applications will not be caught by the \fBtest\fR command. Therefore, usage of the \fB\-output\fR and \fB\-errorOutput\fR options to \fBtest\fR is useful only for pure Tcl applications -that use \fB::puts\fR to produce output. +that use \fBputs\fR to produce output. .SH KEYWORDS test, test harness, test suite +.\" Local Variables: +.\" mode: nroff +.\" End: diff --git a/library/tcltest/pkgIndex.tcl b/library/tcltest/pkgIndex.tcl index 987725f..fde3ffe 100644 --- a/library/tcltest/pkgIndex.tcl +++ b/library/tcltest/pkgIndex.tcl @@ -8,5 +8,5 @@ # script is sourced, the variable $dir must contain the # full path name of this file's directory. -if {![package vsatisfies [package provide Tcl] 8.5]} {return} -package ifneeded tcltest 2.3.8 [list source [file join $dir tcltest.tcl]] +if {![package vsatisfies [package provide Tcl] 8.5-]} {return} +package ifneeded tcltest 2.5.0 [list source [file join $dir tcltest.tcl]] diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index 936acaa..410aa24 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -16,13 +16,13 @@ # Contributions from Don Porter, NIST, 2002. (not subject to US copyright) # All rights reserved. -package require Tcl 8.5 ;# -verbose line uses [info frame] +package require Tcl 8.5- ;# -verbose line uses [info frame] namespace eval tcltest { # When the version number changes, be sure to update the pkgIndex.tcl file, # and the install directory in the Makefiles. When the minor version # changes (new feature) be sure to update the man page as well. - variable Version 2.3.8 + variable Version 2.5.0 # Compatibility support for dumb variables defined in tcltest 1 # Do not use these. Call [package provide Tcl] and [info patchlevel] @@ -347,7 +347,7 @@ namespace eval tcltest { # This is very subtle and tricky, so let me try to explain. # (Hopefully this longer comment will be clear when I come # back in a few months, unlike its predecessor :) ) - # + # # The [outputChannel] command (and underlying variable) have to # be kept in sync with the [configure -outfile] configuration # option ( and underlying variable Option(-outfile) ). This is @@ -362,12 +362,12 @@ namespace eval tcltest { # configuration options to parse the command line option the first # time they are read. These traces are cancelled whenever the # program itself calls [configure]. - # + # # OK, then so to support tcltest 1 compatibility, it seems we want # to get the return from [outputFile] to trigger the read traces, # just in case. # - # BUT! A little known feature of Tcl variable traces is that + # BUT! A little known feature of Tcl variable traces is that # traces are disabled during the handling of other traces. So, # if we trigger read traces on Option(-outfile) and that triggers # command line parsing which turns around and sets an initial @@ -608,19 +608,30 @@ namespace eval tcltest { set code [catch {Configure {*}$args} msg] return -code $code $msg } - + proc AcceptVerbose { level } { set level [AcceptList $level] + set levelMap { + l list + p pass + b body + s skip + t start + e error + l line + m msec + u usec + } + set levelRegexp "^([join [dict values $levelMap] |])\$" if {[llength $level] == 1} { - if {![regexp {^(pass|body|skip|start|error|line)$} $level]} { + if {![regexp $levelRegexp $level]} { # translate single characters abbreviations to expanded list - set level [string map {p pass b body s skip t start e error l line} \ - [split $level {}]] + set level [string map $levelMap [split $level {}]] } } set valid [list] foreach v $level { - if {[regexp {^(pass|body|skip|start|error|line)$} $v]} { + if {[regexp $levelRegexp $v]} { lappend valid $v } } @@ -639,7 +650,7 @@ namespace eval tcltest { skipped tests if 's' is specified, the bodies of failed tests if 'b' is specified, and when tests start if 't' is specified. ErrorInfo is displayed if 'e' is specified. Source file line - information of failed tests is displayed if 'l' is specified. + information of failed tests is displayed if 'l' is specified. } AcceptVerbose verbose # Match and skip patterns default to the empty list, except for @@ -687,7 +698,7 @@ namespace eval tcltest { # some additional output regarding operations of the test harness. # The tcltest package currently implements only up to debug level 3. Option -debug 0 { - Internal debug level + Internal debug level } AcceptInteger debug proc SetSelectedConstraints args { @@ -715,7 +726,7 @@ namespace eval tcltest { } Option -limitconstraints 0 { whether to run only tests with the constraints - } AcceptBoolean limitConstraints + } AcceptBoolean limitConstraints trace add variable Option(-limitconstraints) write \ [namespace code {ClearUnselectedConstraints ;#}] @@ -728,7 +739,7 @@ namespace eval tcltest { # Default is to run each test file in a separate process Option -singleproc 0 { whether to run all tests in one process - } AcceptBoolean singleProcess + } AcceptBoolean singleProcess proc AcceptTemporaryDirectory { directory } { set directory [AcceptAbsolutePath $directory] @@ -1243,10 +1254,6 @@ proc tcltest::DefineConstraintInitializers {} { ConstraintInitializer interactive \ {expr {[info exists ::tcl_interactive] && $::tcl_interactive}} - # Skip slow tests (to enable slow tests add parameter `-constraints slowTest`) - - ConstraintInitializer slowTest {format 0} - # Some tests can only be run if the installation came from a CD # image instead of a web image. Some tests must be skipped if you # are running as root on Unix. Other tests can only be run if you @@ -1261,7 +1268,7 @@ proc tcltest::DefineConstraintInitializers {} { # setting files into nonblocking mode. ConstraintInitializer nonBlockFiles { - set code [expr {[catch {set f [open defs r]}] + set code [expr {[catch {set f [open defs r]}] || [catch {chan configure $f -blocking off}]}] catch {close $f} set code @@ -1275,7 +1282,7 @@ proc tcltest::DefineConstraintInitializers {} { # (Mark Diekhans). ConstraintInitializer asyncPipeClose {expr { - !([string equal unix $::tcl_platform(platform)] + !([string equal unix $::tcl_platform(platform)] && ([catch {exec uname -X | fgrep {Release = 3.2v}}] == 0))}} # Test to see if we have a broken version of sprintf with respect @@ -1834,6 +1841,9 @@ proc tcltest::SubstArguments {argList} { # is optional; default is {}. # returnCodes - Expected return codes. This attribute is # optional; default is {0 2}. +# errorCode - Expected error code. This attribute is +# optional; default is {*}. It is a glob pattern. +# If given, returnCodes defaults to {1}. # setup - Code to run before $script (above). This # attribute is optional; default is {}. # cleanup - Code to run after $script (above). This @@ -1875,7 +1885,7 @@ proc tcltest::test {name description args} { # Pre-define everything to null except output and errorOutput. We # determine whether or not to trap output based on whether or not # these variables (output & errorOutput) are defined. - lassign {} constraints setup cleanup body result returnCodes match + lassign {} constraints setup cleanup body result returnCodes errorCode match # Set the default match mode set match exact @@ -1885,6 +1895,9 @@ proc tcltest::test {name description args} { # 'return' being used in the test script). set returnCodes [list 0 2] + # Set the default error code pattern + set errorCode "*" + # The old test format can't have a 3rd argument (constraints or # script) that starts with '-'. if {[string match -* [lindex $args 0]] || ([llength $args] <= 1)} { @@ -1894,7 +1907,7 @@ proc tcltest::test {name description args} { set testAttributes($element) $value } foreach item {constraints match setup body cleanup \ - result returnCodes output errorOutput} { + result returnCodes errorCode output errorOutput} { if {[info exists testAttributes(-$item)]} { set testAttributes(-$item) [uplevel 1 \ ::concat $testAttributes(-$item)] @@ -1905,7 +1918,7 @@ proc tcltest::test {name description args} { } set validFlags {-setup -cleanup -body -result -returnCodes \ - -match -output -errorOutput -constraints} + -errorCode -match -output -errorOutput -constraints} foreach flag [array names testAttributes] { if {$flag ni $validFlags} { @@ -1937,6 +1950,10 @@ proc tcltest::test {name description args} { foreach {strcode numcode} {ok 0 normal 0 error 1 return 2 break 3 continue 4} { set returnCodes [string map -nocase [list $strcode $numcode] $returnCodes] } + # errorCode without returnCode 1 is meaningless + if {$errorCode ne "*" && 1 ni $returnCodes} { + set returnCodes 1 + } } else { # This is parsing for the old test command format; it is here # for backward compatibility. @@ -1958,7 +1975,7 @@ proc tcltest::test {name description args} { return } - # Save information about the core file. + # Save information about the core file. if {[preserveCore]} { if {[file exists [file join [workingDirectory] core]]} { set coreModTime [file mtime [file join [workingDirectory] core]] @@ -1969,13 +1986,18 @@ proc tcltest::test {name description args} { set code [catch {uplevel 1 $setup} setupMsg] if {$code == 1} { set errorInfo(setup) $::errorInfo - set errorCode(setup) $::errorCode + set errorCodeRes(setup) $::errorCode } set setupFailure [expr {$code != 0}] # Only run the test body if the setup was successful if {!$setupFailure} { + # Register startup time + if {[IsVerbose msec] || [IsVerbose usec]} { + set timeStart [clock microseconds] + } + # Verbose notification of $body start if {[IsVerbose start]} { puts [outputChannel] "---- $name start" @@ -1991,7 +2013,7 @@ proc tcltest::test {name description args} { lassign $testResult actualAnswer returnCode if {$returnCode == 1} { set errorInfo(body) $::errorInfo - set errorCode(body) $::errorCode + set errorCodeRes(body) $::errorCode } } @@ -2000,6 +2022,11 @@ proc tcltest::test {name description args} { if {!$setupFailure && ($returnCode ni $returnCodes)} { set codeFailure 1 } + set errorCodeFailure 0 + if {!$setupFailure && !$codeFailure && $returnCode == 1 && \ + ![string match $errorCode $errorCodeRes(body)]} { + set errorCodeFailure 1 + } # If expected output/error strings exist, we have to compare # them. If the comparison fails, then so did the test. @@ -2043,7 +2070,7 @@ proc tcltest::test {name description args} { set code [catch {uplevel 1 $cleanup} cleanupMsg] if {$code == 1} { set errorInfo(cleanup) $::errorInfo - set errorCode(cleanup) $::errorCode + set errorCodeRes(cleanup) $::errorCode } set cleanupFailure [expr {$code != 0}] @@ -2064,7 +2091,7 @@ proc tcltest::test {name description args} { } else { set coreFailure 1 } - + if {([preserveCore] > 1) && ($coreFailure)} { append coreMsg "\nMoving file to:\ [file join [temporaryDirectory] core-$name]" @@ -2080,11 +2107,21 @@ proc tcltest::test {name description args} { } } + if {[IsVerbose msec] || [IsVerbose usec]} { + set t [expr {[clock microseconds] - $timeStart}] + if {[IsVerbose usec]} { + puts [outputChannel] "++++ $name took $t μs" + } + if {[IsVerbose msec]} { + puts [outputChannel] "++++ $name took [expr {round($t/1000.)}] ms" + } + } + # if we didn't experience any failures, then we passed variable numTests if {!($setupFailure || $cleanupFailure || $coreFailure || $outputFailure || $errorFailure || $codeFailure - || $scriptFailure)} { + || $errorCodeFailure || $scriptFailure)} { if {$testLevel == 1} { incr numTests(Passed) if {[IsVerbose pass]} { @@ -2104,7 +2141,7 @@ proc tcltest::test {name description args} { variable currentFailure true if {![IsVerbose body]} { set body "" - } + } puts [outputChannel] "\n" if {[IsVerbose line]} { if {![catch {set testFrame [info frame -1]}] && @@ -2125,7 +2162,7 @@ proc tcltest::test {name description args} { puts [outputChannel] "$testFile:$testLine: error: test failed:\ $name [string trim $description]" } - } + } puts [outputChannel] "==== $name\ [string trim $description] FAILED" if {[string length $body]} { @@ -2137,7 +2174,7 @@ proc tcltest::test {name description args} { failed:\n$setupMsg" if {[info exists errorInfo(setup)]} { puts [outputChannel] "---- errorInfo(setup): $errorInfo(setup)" - puts [outputChannel] "---- errorCode(setup): $errorCode(setup)" + puts [outputChannel] "---- errorCode(setup): $errorCodeRes(setup)" } } if {$scriptFailure} { @@ -2149,6 +2186,10 @@ proc tcltest::test {name description args} { ($match matching):\n$result" } } + if {$errorCodeFailure} { + puts [outputChannel] "---- Error code was: '$errorCodeRes(body)'" + puts [outputChannel] "---- Error code should have been: '$errorCode'" + } if {$codeFailure} { switch -- $returnCode { 0 { set msg "Test completed normally" } @@ -2164,7 +2205,7 @@ proc tcltest::test {name description args} { if {[IsVerbose error]} { if {[info exists errorInfo(body)] && (1 ni $returnCodes)} { puts [outputChannel] "---- errorInfo: $errorInfo(body)" - puts [outputChannel] "---- errorCode: $errorCode(body)" + puts [outputChannel] "---- errorCode: $errorCodeRes(body)" } } } @@ -2190,7 +2231,7 @@ proc tcltest::test {name description args} { puts [outputChannel] "---- Test cleanup failed:\n$cleanupMsg" if {[info exists errorInfo(cleanup)]} { puts [outputChannel] "---- errorInfo(cleanup): $errorInfo(cleanup)" - puts [outputChannel] "---- errorCode(cleanup): $errorCode(cleanup)" + puts [outputChannel] "---- errorCode(cleanup): $errorCodeRes(cleanup)" } } if {$coreFailure} { @@ -2281,7 +2322,7 @@ proc tcltest::Skipped {name constraints} { } } } - + if {!$doTest} { if {[IsVerbose skip]} { puts [outputChannel] "++++ $name SKIPPED: $constraints" @@ -2687,7 +2728,7 @@ proc tcltest::GetMatchingDirectories {rootdir} { DebugPuts 1 "No test directories remain after applying match\ and skip patterns!" } - return $matchDirs + return [lsort $matchDirs] } # tcltest::runAllTests -- @@ -2700,7 +2741,7 @@ proc tcltest::GetMatchingDirectories {rootdir} { # shell being tested # # Results: -# None. +# Whether there were any failures. # # Side effects: # None. @@ -2838,15 +2879,15 @@ proc tcltest::runAllTests { {shell ""} } { set dir [file tail $directory] puts [outputChannel] [string repeat ~ 44] puts [outputChannel] "$dir test began at [eval $timeCmd]\n" - + uplevel 1 [list ::source [file join $directory all.tcl]] - + set endTime [eval $timeCmd] puts [outputChannel] "\n$dir test ended at $endTime" puts [outputChannel] "" puts [outputChannel] [string repeat ~ 44] } - return + return [info exists testFileFailures] } ##################################################################### @@ -3023,7 +3064,7 @@ proc tcltest::removeFile {name {directory ""}} { DebugDo 1 { Warn "removeFile removing \"$fullName\":\n not created by makeFile" } - } + } if {![file isfile $fullName]} { DebugDo 1 { Warn "removeFile removing \"$fullName\":\n not a file" @@ -3094,7 +3135,7 @@ proc tcltest::removeDirectory {name {directory ""}} { Warn "removeDirectory removing \"$fullName\":\n not created\ by makeDirectory" } - } + } if {![file isdirectory $fullName]} { DebugDo 1 { Warn "removeDirectory removing \"$fullName\":\n not a directory" @@ -3289,7 +3330,7 @@ proc tcltest::threadReap {} { testthread errorproc ThreadError return [llength [testthread names]] } elseif {[info commands thread::id] ne {}} { - + # Thread extension thread::errorproc ThreadNullError diff --git a/tests/tcltest.test b/tests/tcltest.test index 028d4fa..ca720ee 100644 --- a/tests/tcltest.test +++ b/tests/tcltest.test @@ -46,6 +46,7 @@ makeFile { cd [temporaryDirectory] testConstraint exec [llength [info commands exec]] + # test -help # Child processes because -help [exit]s. test tcltest-1.1 {tcltest -help} {exec} { @@ -142,7 +143,7 @@ test tcltest-2.5a {tcltest -verbose 'pass skip body'} {unixOrPc} { } {0 1 1 1 1} test tcltest-2.6 {tcltest -verbose 't'} { - -constraints {unixOrPc} + -constraints {unixOrPc} -body { set result [slave msg test.tcl -verbose 't'] list $result $msg @@ -152,7 +153,7 @@ test tcltest-2.6 {tcltest -verbose 't'} { } test tcltest-2.6a {tcltest -verbose 'start'} { - -constraints {unixOrPc} + -constraints {unixOrPc} -body { set result [slave msg test.tcl -verbose start] list $result $msg @@ -169,7 +170,7 @@ test tcltest-2.7 {tcltest::verbose} { verbose foo set newVerbosity [verbose] verbose $oldVerbosity - list $currentVerbosity $newVerbosity + list $currentVerbosity $newVerbosity } -result {body {}} } @@ -217,7 +218,7 @@ test tcltest-3.5 {tcltest::match} { } -result {foo bar} } - + # -skip, [skip] test tcltest-4.1 {tcltest -skip 'a*'} {unixOrPc} { set result [slave msg test.tcl -skip a* -verbose 'ps'] @@ -299,8 +300,8 @@ test tcltest-5.3 {testConstraint - constraint empty (tcltest::safeFetch)} { # -result {{} tcltestFakeConstraint1 {tcltestFakeConstraint1 tcltestFakeConstraint2}} # -cleanup { # set ::tcltest::constraintsSpecified $constraintlist -# unset ::tcltest::testConstraints(tcltestFakeConstraint1) -# unset ::tcltest::testConstraints(tcltestFakeConstraint2) +# unset ::tcltest::testConstraints(tcltestFakeConstraint1) +# unset ::tcltest::testConstraints(tcltestFakeConstraint2) # } #} @@ -311,7 +312,7 @@ test tcltest-5.5 {InitConstraints: list of built-in constraints} \ -result [lsort { 95 98 asyncPipeClose eformat emptyTest exec hasIsoLocale interactive knownBug mac macCrash macOnly macOrPc macOrUnix macOrWin nonBlockFiles - nonPortable notRoot nt pc pcCrash pcOnly root singleTestInterp slowTest socket + nonPortable notRoot nt pc pcCrash pcOnly root singleTestInterp socket stdio tempNotMac tempNotPc tempNotUnix tempNotWin unix unixCrash unixExecs unixOnly unixOrPc unixOrWin userInteraction win winCrash winOnly }] @@ -348,7 +349,7 @@ set printerror [makeFile { ::tcltest::PrintError "a really really long string containing a \ \"Path/that/is/really/long/and/contains/no/spaces\"" ::tcltest::PrintError "a really really long string containing a \ - \"Really/Long/Path/that/contains/no/spaces/and/is/longer/than/eighty/characters/to/see/what/happens\"" + \"Really/Long/Path/that/contains/no/spaces/and/is/longer/than/eighty/characters/to/see/what/happens\"" ::tcltest::PrintError "Problem renaming file: error renaming \"Z:/ws/tcl8.2/win32-ix86/tests/core\" to \"Z:/ws/tcl8.2/win32-ix86/tests/movecore-core\"" exit } printerror.tcl] @@ -367,7 +368,7 @@ test tcltest-6.2 {tcltest -outfile a.tmp} {unixOrPc unixExecs} { set result1 [catch {exec grep "a test" a.tmp}] set result2 [catch {exec grep "a really" a.tmp}] list [regexp "a test" $msg] [regexp "a really" $msg] \ - $result1 $result2 [file exists a.tmp] [file delete a.tmp] + $result1 $result2 [file exists a.tmp] [file delete a.tmp] } {0 1 0 1 1 {}} test tcltest-6.3 {tcltest -errfile a.tmp} {unixOrPc unixExecs} { slave msg $printerror -errfile a.tmp @@ -413,7 +414,7 @@ test tcltest-6.6 {tcltest::errorFile (implicit errorChannel)} { set f2 [errorFile $ef] set f3 [errorChannel] set f4 [errorFile] - subst {$f0;$f1;$f2;$f3;$f4} + subst {$f0;$f1;$f2;$f3;$f4} } -result {stderr;stderr;.*efile;file[0-9a-f]+;.*efile} -match regexp @@ -449,7 +450,7 @@ test tcltest-6.8 {tcltest::outputFile (implicit outputFile)} { set f2 [outputFile $ef] set f3 [outputChannel] set f4 [outputFile] - subst {$f0;$f1;$f2;$f3;$f4} + subst {$f0;$f1;$f2;$f3;$f4} } -result {stdout;stdout;.*efile;file[0-9a-f]+;.*efile} -match regexp @@ -719,7 +720,7 @@ switch -- $::tcl_platform(platform) { file attributes $notWriteableDir -permissions 777 } default { - catch {testchmod 777 $notWriteableDir} + catch {testchmod 0o777 $notWriteableDir} catch {file attributes $notWriteableDir -readonly 0} } } @@ -760,7 +761,7 @@ test tcltest-9.3 {matchFiles} { set new [matchFiles] matchFiles $old list $current $new - } + } -result {foo bar} } @@ -773,7 +774,7 @@ test tcltest-9.4 {skipFiles} { set new [skipFiles] skipFiles $old list $current $new - } + } -result {foo bar} } @@ -907,7 +908,9 @@ removeFile load.tcl # [interpreter] test tcltest-13.1 {interpreter} { + -constraints notValgrind -setup { + #to do: Why is $::tcltest::tcltest being saved and restored here? set old $::tcltest::tcltest set ::tcltest::tcltest tcltest } @@ -919,6 +922,11 @@ test tcltest-13.1 {interpreter} { } -result {tcltest tclsh tclsh} -cleanup { + # writing ::tcltest::tcltest triggers a trace that sets up the stdio + # constraint, which involves a call to [exec] that might fail after + # "fork" and before "exec", in which case the forked process will not + # have a chance to clean itself up before exiting, which causes + # valgrind to issue numerous "still reachable" reports. set ::tcltest::tcltest $old } } @@ -1148,7 +1156,7 @@ test tcltest-19.1 {TCLTEST_OPTIONS default} -setup { interp delete slave2 interp delete slave1 if {$oldoptions eq "none"} { - unset ::env(TCLTEST_OPTIONS) + unset ::env(TCLTEST_OPTIONS) } else { set ::env(TCLTEST_OPTIONS) $oldoptions } @@ -1199,7 +1207,7 @@ test tcltest-21.2 {force a test command failure} { } {1} } -returnCodes 1 - -result {bad option "1": must be -body, -cleanup, -constraints, -errorOutput, -match, -output, -result, -returnCodes, or -setup} + -result {bad option "1": must be -body, -cleanup, -constraints, -errorCode, -errorOutput, -match, -output, -result, -returnCodes, or -setup} } test tcltest-21.3 {test command with setup} { @@ -1262,7 +1270,7 @@ test tcltest-21.6 {test command - setup occurs before cleanup & before script} { } set foo 1 set expected 2 - } + } -body { incr foo set foo @@ -1292,7 +1300,7 @@ test tcltest-21.7 {test command - bad flag} { } } -returnCodes 1 - -result {bad option "-foobar": must be -body, -cleanup, -constraints, -errorOutput, -match, -output, -result, -returnCodes, or -setup} + -result {bad option "-foobar": must be -body, -cleanup, -constraints, -errorCode, -errorOutput, -match, -output, -result, -returnCodes, or -setup} } # alternate test command format (these are the same as 21.1-21.6, with the @@ -1312,7 +1320,7 @@ test tcltest-21.8 {force a test command failure} \ } \ -returnCodes 1 \ -cleanup {set ::tcltest::currentFailure $fail} \ - -result {bad option "1": must be -body, -cleanup, -constraints, -errorOutput, -match, -output, -result, -returnCodes, or -setup} + -result {bad option "1": must be -body, -cleanup, -constraints, -errorCode, -errorOutput, -match, -output, -result, -returnCodes, or -setup} test tcltest-21.9 {test command with setup} \ -setup {set foo 1} \ @@ -1426,7 +1434,7 @@ test tcltest-23.1 {makeFile} { } -cleanup { file delete -force $mfdir \ - [file join [temporaryDirectory] t1.tmp] + [file join [temporaryDirectory] t1.tmp] } -result {1 1} } @@ -1449,7 +1457,7 @@ test tcltest-23.2 {removeFile} { } -cleanup { file delete -force $mfdir \ - [file join [temporaryDirectory] t1.tmp] + [file join [temporaryDirectory] t1.tmp] } -result {0 0} } @@ -1826,9 +1834,13 @@ test tcltest-26.2 {Bug/RFE 1017151} -setup { ---- errorInfo: body error * ---- errorInfo(cleanup): cleanup error*} - + cleanupTests } namespace delete ::tcltest::test return + +# Local Variables: +# mode: tcl +# End: diff --git a/unix/Makefile.in b/unix/Makefile.in index 50f4bb3..7e8e4a3 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -785,8 +785,8 @@ install-libraries: libraries $(INSTALL_TZDATA) install-msgs done; @echo "Installing package msgcat 1.5.2 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/msgcat-1.5.2.tm; - @echo "Installing package tcltest 2.3.8 as a Tcl Module"; - @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.3.8.tm; + @echo "Installing package tcltest 2.5.0 as a Tcl Module"; + @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.5.0.tm; @echo "Installing package platform 1.0.14 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/platform/platform.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform-1.0.14.tm; diff --git a/win/Makefile.in b/win/Makefile.in index 7fc415d..f197190 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -659,8 +659,8 @@ install-libraries: libraries install-tzdata install-msgs done; @echo "Installing package msgcat 1.5.2 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.5.2.tm; - @echo "Installing package tcltest 2.3.8 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.3.8.tm; + @echo "Installing package tcltest 2.5.0 as a Tcl Module"; + @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.5.0.tm; @echo "Installing package platform 1.0.14 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/platform/platform.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.4/platform-1.0.14.tm; @echo "Installing package platform::shell 1.1.4 as a Tcl Module"; diff --git a/win/makefile.bc b/win/makefile.bc index 577c865..8f337e3 100644 --- a/win/makefile.bc +++ b/win/makefile.bc @@ -432,10 +432,10 @@ install-libraries: -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\msgcat1.5" -@copy "$(ROOT)\library\msgcat\msgcat.tcl" "$(SCRIPT_INSTALL_DIR)\msgcat1.5" -@copy "$(ROOT)\library\msgcat\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\msgcat1.5" - @echo Installing tcltest2.3 - -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\tcltest2.3" - -@copy "$(ROOT)\library\tcltest\tcltest.tcl" "$(SCRIPT_INSTALL_DIR)\tcltest2.3" - -@copy "$(ROOT)\library\tcltest\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\tcltest2.3" + @echo Installing tcltest2.5 + -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\tcltest2.5" + -@copy "$(ROOT)\library\tcltest\tcltest.tcl" "$(SCRIPT_INSTALL_DIR)\tcltest2.5" + -@copy "$(ROOT)\library\tcltest\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\tcltest2.5" @echo Installing platform1.0 -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\platform1.0" -@copy "$(ROOT)\library\platform\platform.tcl" "$(SCRIPT_INSTALL_DIR)\platform1.0" -- cgit v0.12 From ce6023fade965eb75c891c4d455cd95c25a169d1 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 29 Oct 2018 14:38:24 +0000 Subject: [TIP 525] Backport package tcltest 2.5 --- doc/tcltest.n | 14 ++++++++++++-- library/tcltest/pkgIndex.tcl | 4 ++-- library/tcltest/tcltest.tcl | 45 +++++++++++++++++++++++++++++++------------- tests/tcltest.test | 10 +++++----- unix/Makefile.in | 4 ++-- win/Makefile.in | 4 ++-- 6 files changed, 55 insertions(+), 26 deletions(-) diff --git a/doc/tcltest.n b/doc/tcltest.n index 05c1922..b161a2b 100644 --- a/doc/tcltest.n +++ b/doc/tcltest.n @@ -8,7 +8,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.TH "tcltest" n 2.3 tcltest "Tcl Bundled Packages" +.TH "tcltest" n 2.5 tcltest "Tcl Bundled Packages" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! @@ -16,7 +16,7 @@ tcltest \- Test harness support code and utilities .SH SYNOPSIS .nf -\fBpackage require tcltest\fR ?\fB2.3\fR? +\fBpackage require tcltest\fR ?\fB2.5\fR? \fBtcltest::test \fIname description\fR ?\fI\-option value ...\fR? \fBtcltest::test \fIname description\fR ?\fIconstraints\fR? \fIbody result\fR @@ -454,6 +454,7 @@ The valid options for \fBtest\fR are summarized: ?\fB\-output \fIexpectedOutput\fR? ?\fB\-errorOutput \fIexpectedError\fR? ?\fB\-returnCodes \fIcodeList\fR? + ?\fB\-errorCode \fIexpectedErrorCode\fR? ?\fB\-match \fImode\fR? .CE .PP @@ -577,6 +578,15 @@ return codes known to \fBreturn\fR, in both numeric and symbolic form, including extended return codes, are acceptable elements in the \fIexpectedCodeList\fR. Default value is .QW "\fBok return\fR" . +.TP +\fB\-errorCode \fIexpectedErrorCode\fR +. +The optional \fB\-errorCode\fR attribute supplies \fIexpectedErrorCode\fR, +a glob pattern that should match the error code reported from evaluation of the +\fB\-body\fR script. If evaluation of the \fB\-body\fR script returns +a code not matching \fIexpectedErrorCode\fR, the test fails. Default value is +.QW "\fB*\fR" . +If \fB\-returnCodes\fR does not include \fBerror\fR it is set to \fBerror\fR. .PP To pass, a test must successfully evaluate its \fB\-setup\fR, \fB\-body\fR, and \fB\-cleanup\fR scripts. The return code of the \fB\-body\fR script and diff --git a/library/tcltest/pkgIndex.tcl b/library/tcltest/pkgIndex.tcl index c9d3759..fde3ffe 100644 --- a/library/tcltest/pkgIndex.tcl +++ b/library/tcltest/pkgIndex.tcl @@ -8,5 +8,5 @@ # script is sourced, the variable $dir must contain the # full path name of this file's directory. -if {![package vsatisfies [package provide Tcl] 8.5]} {return} -package ifneeded tcltest 2.4.1 [list source [file join $dir tcltest.tcl]] +if {![package vsatisfies [package provide Tcl] 8.5-]} {return} +package ifneeded tcltest 2.5.0 [list source [file join $dir tcltest.tcl]] diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index f1b6082..410aa24 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -22,7 +22,7 @@ namespace eval tcltest { # When the version number changes, be sure to update the pkgIndex.tcl file, # and the install directory in the Makefiles. When the minor version # changes (new feature) be sure to update the man page as well. - variable Version 2.4.1 + variable Version 2.5.0 # Compatibility support for dumb variables defined in tcltest 1 # Do not use these. Call [package provide Tcl] and [info patchlevel] @@ -1841,6 +1841,9 @@ proc tcltest::SubstArguments {argList} { # is optional; default is {}. # returnCodes - Expected return codes. This attribute is # optional; default is {0 2}. +# errorCode - Expected error code. This attribute is +# optional; default is {*}. It is a glob pattern. +# If given, returnCodes defaults to {1}. # setup - Code to run before $script (above). This # attribute is optional; default is {}. # cleanup - Code to run after $script (above). This @@ -1882,7 +1885,7 @@ proc tcltest::test {name description args} { # Pre-define everything to null except output and errorOutput. We # determine whether or not to trap output based on whether or not # these variables (output & errorOutput) are defined. - lassign {} constraints setup cleanup body result returnCodes match + lassign {} constraints setup cleanup body result returnCodes errorCode match # Set the default match mode set match exact @@ -1892,6 +1895,9 @@ proc tcltest::test {name description args} { # 'return' being used in the test script). set returnCodes [list 0 2] + # Set the default error code pattern + set errorCode "*" + # The old test format can't have a 3rd argument (constraints or # script) that starts with '-'. if {[string match -* [lindex $args 0]] || ([llength $args] <= 1)} { @@ -1901,7 +1907,7 @@ proc tcltest::test {name description args} { set testAttributes($element) $value } foreach item {constraints match setup body cleanup \ - result returnCodes output errorOutput} { + result returnCodes errorCode output errorOutput} { if {[info exists testAttributes(-$item)]} { set testAttributes(-$item) [uplevel 1 \ ::concat $testAttributes(-$item)] @@ -1912,7 +1918,7 @@ proc tcltest::test {name description args} { } set validFlags {-setup -cleanup -body -result -returnCodes \ - -match -output -errorOutput -constraints} + -errorCode -match -output -errorOutput -constraints} foreach flag [array names testAttributes] { if {$flag ni $validFlags} { @@ -1944,6 +1950,10 @@ proc tcltest::test {name description args} { foreach {strcode numcode} {ok 0 normal 0 error 1 return 2 break 3 continue 4} { set returnCodes [string map -nocase [list $strcode $numcode] $returnCodes] } + # errorCode without returnCode 1 is meaningless + if {$errorCode ne "*" && 1 ni $returnCodes} { + set returnCodes 1 + } } else { # This is parsing for the old test command format; it is here # for backward compatibility. @@ -1976,7 +1986,7 @@ proc tcltest::test {name description args} { set code [catch {uplevel 1 $setup} setupMsg] if {$code == 1} { set errorInfo(setup) $::errorInfo - set errorCode(setup) $::errorCode + set errorCodeRes(setup) $::errorCode } set setupFailure [expr {$code != 0}] @@ -2003,7 +2013,7 @@ proc tcltest::test {name description args} { lassign $testResult actualAnswer returnCode if {$returnCode == 1} { set errorInfo(body) $::errorInfo - set errorCode(body) $::errorCode + set errorCodeRes(body) $::errorCode } } @@ -2012,6 +2022,11 @@ proc tcltest::test {name description args} { if {!$setupFailure && ($returnCode ni $returnCodes)} { set codeFailure 1 } + set errorCodeFailure 0 + if {!$setupFailure && !$codeFailure && $returnCode == 1 && \ + ![string match $errorCode $errorCodeRes(body)]} { + set errorCodeFailure 1 + } # If expected output/error strings exist, we have to compare # them. If the comparison fails, then so did the test. @@ -2055,7 +2070,7 @@ proc tcltest::test {name description args} { set code [catch {uplevel 1 $cleanup} cleanupMsg] if {$code == 1} { set errorInfo(cleanup) $::errorInfo - set errorCode(cleanup) $::errorCode + set errorCodeRes(cleanup) $::errorCode } set cleanupFailure [expr {$code != 0}] @@ -2106,7 +2121,7 @@ proc tcltest::test {name description args} { variable numTests if {!($setupFailure || $cleanupFailure || $coreFailure || $outputFailure || $errorFailure || $codeFailure - || $scriptFailure)} { + || $errorCodeFailure || $scriptFailure)} { if {$testLevel == 1} { incr numTests(Passed) if {[IsVerbose pass]} { @@ -2159,7 +2174,7 @@ proc tcltest::test {name description args} { failed:\n$setupMsg" if {[info exists errorInfo(setup)]} { puts [outputChannel] "---- errorInfo(setup): $errorInfo(setup)" - puts [outputChannel] "---- errorCode(setup): $errorCode(setup)" + puts [outputChannel] "---- errorCode(setup): $errorCodeRes(setup)" } } if {$scriptFailure} { @@ -2171,6 +2186,10 @@ proc tcltest::test {name description args} { ($match matching):\n$result" } } + if {$errorCodeFailure} { + puts [outputChannel] "---- Error code was: '$errorCodeRes(body)'" + puts [outputChannel] "---- Error code should have been: '$errorCode'" + } if {$codeFailure} { switch -- $returnCode { 0 { set msg "Test completed normally" } @@ -2186,7 +2205,7 @@ proc tcltest::test {name description args} { if {[IsVerbose error]} { if {[info exists errorInfo(body)] && (1 ni $returnCodes)} { puts [outputChannel] "---- errorInfo: $errorInfo(body)" - puts [outputChannel] "---- errorCode: $errorCode(body)" + puts [outputChannel] "---- errorCode: $errorCodeRes(body)" } } } @@ -2212,7 +2231,7 @@ proc tcltest::test {name description args} { puts [outputChannel] "---- Test cleanup failed:\n$cleanupMsg" if {[info exists errorInfo(cleanup)]} { puts [outputChannel] "---- errorInfo(cleanup): $errorInfo(cleanup)" - puts [outputChannel] "---- errorCode(cleanup): $errorCode(cleanup)" + puts [outputChannel] "---- errorCode(cleanup): $errorCodeRes(cleanup)" } } if {$coreFailure} { @@ -2722,7 +2741,7 @@ proc tcltest::GetMatchingDirectories {rootdir} { # shell being tested # # Results: -# None. +# Whether there were any failures. # # Side effects: # None. @@ -2868,7 +2887,7 @@ proc tcltest::runAllTests { {shell ""} } { puts [outputChannel] "" puts [outputChannel] [string repeat ~ 44] } - return + return [info exists testFileFailures] } ##################################################################### diff --git a/tests/tcltest.test b/tests/tcltest.test index 0bcf342..ca720ee 100644 --- a/tests/tcltest.test +++ b/tests/tcltest.test @@ -908,7 +908,7 @@ removeFile load.tcl # [interpreter] test tcltest-13.1 {interpreter} { - -constraints notValgrind + -constraints notValgrind -setup { #to do: Why is $::tcltest::tcltest being saved and restored here? set old $::tcltest::tcltest @@ -926,7 +926,7 @@ test tcltest-13.1 {interpreter} { # constraint, which involves a call to [exec] that might fail after # "fork" and before "exec", in which case the forked process will not # have a chance to clean itself up before exiting, which causes - # valgrind to issue numerous "still reachable" reports. + # valgrind to issue numerous "still reachable" reports. set ::tcltest::tcltest $old } } @@ -1207,7 +1207,7 @@ test tcltest-21.2 {force a test command failure} { } {1} } -returnCodes 1 - -result {bad option "1": must be -body, -cleanup, -constraints, -errorOutput, -match, -output, -result, -returnCodes, or -setup} + -result {bad option "1": must be -body, -cleanup, -constraints, -errorCode, -errorOutput, -match, -output, -result, -returnCodes, or -setup} } test tcltest-21.3 {test command with setup} { @@ -1300,7 +1300,7 @@ test tcltest-21.7 {test command - bad flag} { } } -returnCodes 1 - -result {bad option "-foobar": must be -body, -cleanup, -constraints, -errorOutput, -match, -output, -result, -returnCodes, or -setup} + -result {bad option "-foobar": must be -body, -cleanup, -constraints, -errorCode, -errorOutput, -match, -output, -result, -returnCodes, or -setup} } # alternate test command format (these are the same as 21.1-21.6, with the @@ -1320,7 +1320,7 @@ test tcltest-21.8 {force a test command failure} \ } \ -returnCodes 1 \ -cleanup {set ::tcltest::currentFailure $fail} \ - -result {bad option "1": must be -body, -cleanup, -constraints, -errorOutput, -match, -output, -result, -returnCodes, or -setup} + -result {bad option "1": must be -body, -cleanup, -constraints, -errorCode, -errorOutput, -match, -output, -result, -returnCodes, or -setup} test tcltest-21.9 {test command with setup} \ -setup {set foo 1} \ diff --git a/unix/Makefile.in b/unix/Makefile.in index a2621a3..66114ba 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -851,8 +851,8 @@ install-libraries: libraries done; @echo "Installing package msgcat 1.6.1 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/msgcat-1.6.1.tm; - @echo "Installing package tcltest 2.4.1 as a Tcl Module"; - @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.4.1.tm; + @echo "Installing package tcltest 2.5.0 as a Tcl Module"; + @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.5.0.tm; @echo "Installing package platform 1.0.14 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/platform/platform.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform-1.0.14.tm; diff --git a/win/Makefile.in b/win/Makefile.in index 8ce57f2..9d955cd 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -660,8 +660,8 @@ install-libraries: libraries install-tzdata install-msgs done; @echo "Installing package msgcat 1.6.1 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.6.1.tm; - @echo "Installing package tcltest 2.4.1 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.4.1.tm; + @echo "Installing package tcltest 2.5.0 as a Tcl Module"; + @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.5.0.tm; @echo "Installing package platform 1.0.14 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/platform/platform.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.4/platform-1.0.14.tm; @echo "Installing package platform::shell 1.1.4 as a Tcl Module"; -- cgit v0.12 From 820cc5a23de910d5fb10e46bbd778acccc9c866b Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 29 Oct 2018 18:19:55 +0000 Subject: Work started eliminating long outdated compat routines that now cause cross-compiling failure far more often than they help porting to old broken platforms. --- compat/fixstrtod.c | 36 -------- compat/stdlib.h | 1 - compat/strtod.c | 252 ----------------------------------------------------- unix/Makefile.in | 6 -- unix/configure | 134 ---------------------------- unix/configure.ac | 20 ----- unix/tcl.m4 | 53 ----------- 7 files changed, 502 deletions(-) delete mode 100644 compat/fixstrtod.c delete mode 100644 compat/strtod.c diff --git a/compat/fixstrtod.c b/compat/fixstrtod.c deleted file mode 100644 index 63fb8ef..0000000 --- a/compat/fixstrtod.c +++ /dev/null @@ -1,36 +0,0 @@ -/* - * fixstrtod.c -- - * - * Source code for the "fixstrtod" procedure. This procedure is - * used in place of strtod under Solaris 2.4, in order to fix - * a bug where the "end" pointer gets set incorrectly. - * - * Copyright (c) 1995 Sun Microsystems, Inc. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - */ - -#include - -#undef strtod - -/* - * Declare strtod explicitly rather than including stdlib.h, since in - * somes systems (e.g. SunOS 4.1.4) stdlib.h doesn't declare strtod. - */ - -extern double strtod(char *, char **); - -double -fixstrtod( - char *string, - char **endPtr) -{ - double d; - d = strtod(string, endPtr); - if ((endPtr != NULL) && (*endPtr != string) && ((*endPtr)[-1] == 0)) { - *endPtr -= 1; - } - return d; -} diff --git a/compat/stdlib.h b/compat/stdlib.h index 0ad4c1d..6900be3 100644 --- a/compat/stdlib.h +++ b/compat/stdlib.h @@ -29,7 +29,6 @@ extern char * malloc(unsigned int numBytes); extern void qsort(void *base, int n, int size, int (*compar)( const void *element1, const void *element2)); extern char * realloc(char *ptr, unsigned int numBytes); -extern double strtod(const char *string, char **endPtr); extern long strtol(const char *string, char **endPtr, int base); extern unsigned long strtoul(const char *string, char **endPtr, int base); diff --git a/compat/strtod.c b/compat/strtod.c deleted file mode 100644 index 9643c09..0000000 --- a/compat/strtod.c +++ /dev/null @@ -1,252 +0,0 @@ -/* - * strtod.c -- - * - * Source code for the "strtod" library procedure. - * - * Copyright (c) 1988-1993 The Regents of the University of California. - * Copyright (c) 1994 Sun Microsystems, Inc. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - */ - -#include "tclInt.h" - -#ifndef TRUE -#define TRUE 1 -#define FALSE 0 -#endif -#ifndef NULL -#define NULL 0 -#endif - -static const int maxExponent = 511; /* Largest possible base 10 exponent. Any - * exponent larger than this will already - * produce underflow or overflow, so there's - * no need to worry about additional digits. - */ -static const double powersOf10[] = { /* Table giving binary powers of 10. Entry */ - 10., /* is 10^2^i. Used to convert decimal */ - 100., /* exponents into floating-point numbers. */ - 1.0e4, - 1.0e8, - 1.0e16, - 1.0e32, - 1.0e64, - 1.0e128, - 1.0e256 -}; - -/* - *---------------------------------------------------------------------- - * - * strtod -- - * - * This procedure converts a floating-point number from an ASCII - * decimal representation to internal double-precision format. - * - * Results: - * The return value is the double-precision floating-point - * representation of the characters in string. If endPtr isn't - * NULL, then *endPtr is filled in with the address of the - * next character after the last one that was part of the - * floating-point number. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -double -strtod( - const char *string, /* A decimal ASCII floating-point number, - * optionally preceded by white space. Must - * have form "-I.FE-X", where I is the integer - * part of the mantissa, F is the fractional - * part of the mantissa, and X is the - * exponent. Either of the signs may be "+", - * "-", or omitted. Either I or F may be - * omitted, or both. The decimal point isn't - * necessary unless F is present. The "E" may - * actually be an "e". E and X may both be - * omitted (but not just one). */ - char **endPtr) /* If non-NULL, store terminating character's - * address here. */ -{ - int sign, expSign = FALSE; - double fraction, dblExp; - const double *d; - register const char *p; - register int c; - int exp = 0; /* Exponent read from "EX" field. */ - int fracExp = 0; /* Exponent that derives from the fractional - * part. Under normal circumstatnces, it is - * the negative of the number of digits in F. - * However, if I is very long, the last digits - * of I get dropped (otherwise a long I with a - * large negative exponent could cause an - * unnecessary overflow on I alone). In this - * case, fracExp is incremented one for each - * dropped digit. */ - int mantSize; /* Number of digits in mantissa. */ - int decPt; /* Number of mantissa digits BEFORE decimal - * point. */ - const char *pExp; /* Temporarily holds location of exponent in - * string. */ - - /* - * Strip off leading blanks and check for a sign. - */ - - p = string; - while (isspace(UCHAR(*p))) { - p += 1; - } - if (*p == '-') { - sign = TRUE; - p += 1; - } else { - if (*p == '+') { - p += 1; - } - sign = FALSE; - } - - /* - * Count the number of digits in the mantissa (including the decimal - * point), and also locate the decimal point. - */ - - decPt = -1; - for (mantSize = 0; ; mantSize += 1) - { - c = *p; - if (!isdigit(c)) { - if ((c != '.') || (decPt >= 0)) { - break; - } - decPt = mantSize; - } - p += 1; - } - - /* - * Now suck up the digits in the mantissa. Use two integers to collect 9 - * digits each (this is faster than using floating-point). If the mantissa - * has more than 18 digits, ignore the extras, since they can't affect the - * value anyway. - */ - - pExp = p; - p -= mantSize; - if (decPt < 0) { - decPt = mantSize; - } else { - mantSize -= 1; /* One of the digits was the point. */ - } - if (mantSize > 18) { - fracExp = decPt - 18; - mantSize = 18; - } else { - fracExp = decPt - mantSize; - } - if (mantSize == 0) { - fraction = 0.0; - p = string; - goto done; - } else { - int frac1, frac2; - - frac1 = 0; - for ( ; mantSize > 9; mantSize -= 1) { - c = *p; - p += 1; - if (c == '.') { - c = *p; - p += 1; - } - frac1 = 10*frac1 + (c - '0'); - } - frac2 = 0; - for (; mantSize > 0; mantSize -= 1) { - c = *p; - p += 1; - if (c == '.') { - c = *p; - p += 1; - } - frac2 = 10*frac2 + (c - '0'); - } - fraction = (1.0e9 * frac1) + frac2; - } - - /* - * Skim off the exponent. - */ - - p = pExp; - if ((*p == 'E') || (*p == 'e')) { - p += 1; - if (*p == '-') { - expSign = TRUE; - p += 1; - } else { - if (*p == '+') { - p += 1; - } - expSign = FALSE; - } - if (!isdigit(UCHAR(*p))) { - p = pExp; - goto done; - } - while (isdigit(UCHAR(*p))) { - exp = exp * 10 + (*p - '0'); - p += 1; - } - } - if (expSign) { - exp = fracExp - exp; - } else { - exp = fracExp + exp; - } - - /* - * Generate a floating-point number that represents the exponent. Do this - * by processing the exponent one bit at a time to combine many powers of - * 2 of 10. Then combine the exponent with the fraction. - */ - - if (exp < 0) { - expSign = TRUE; - exp = -exp; - } else { - expSign = FALSE; - } - if (exp > maxExponent) { - exp = maxExponent; - errno = ERANGE; - } - dblExp = 1.0; - for (d = powersOf10; exp != 0; exp >>= 1, ++d) { - if (exp & 01) { - dblExp *= *d; - } - } - if (expSign) { - fraction /= dblExp; - } else { - fraction *= dblExp; - } - - done: - if (endPtr != NULL) { - *endPtr = (char *) p; - } - - if (sign) { - return -fraction; - } - return fraction; -} diff --git a/unix/Makefile.in b/unix/Makefile.in index b4fd97a..4dea6c1 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -1744,9 +1744,6 @@ tclXtTest.o: $(UNIX_DIR)/tclXtTest.c # relocatable. #-------------------------------------------------------------------------- -fixstrtod.o: $(COMPAT_DIR)/fixstrtod.c - $(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/fixstrtod.c - opendir.o: $(COMPAT_DIR)/opendir.c $(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/opendir.c @@ -1762,9 +1759,6 @@ strncasecmp.o: $(COMPAT_DIR)/strncasecmp.c strstr.o: $(COMPAT_DIR)/strstr.c $(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/strstr.c -strtod.o: $(COMPAT_DIR)/strtod.c - $(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/strtod.c - strtol.o: $(COMPAT_DIR)/strtol.c $(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/strtol.c diff --git a/unix/configure b/unix/configure index 013a8b3..7a10580 100755 --- a/unix/configure +++ b/unix/configure @@ -8839,140 +8839,6 @@ esac #-------------------------------------------------------------------- -# Check for the strtod function. This is tricky because in some -# versions of Linux strtod mis-parses strings starting with "+". -#-------------------------------------------------------------------- - - - ac_fn_c_check_func "$LINENO" "strtod" "ac_cv_func_strtod" -if test "x$ac_cv_func_strtod" = xyes; then : - tcl_ok=1 -else - tcl_ok=0 -fi - - if test "$tcl_ok" = 1; then - { $as_echo "$as_me:${as_lineno-$LINENO}: checking proper strtod implementation" >&5 -$as_echo_n "checking proper strtod implementation... " >&6; } -if ${tcl_cv_strtod_unbroken+:} false; then : - $as_echo_n "(cached) " >&6 -else - if test "$cross_compiling" = yes; then : - tcl_cv_strtod_unbroken=unknown -else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -int main() { - extern double strtod(); - char *term, *string = " +69"; - exit(strtod(string,&term) != 69 || term != string+4); -} -_ACEOF -if ac_fn_c_try_run "$LINENO"; then : - tcl_cv_strtod_unbroken=ok -else - tcl_cv_strtod_unbroken=broken -fi -rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ - conftest.$ac_objext conftest.beam conftest.$ac_ext -fi - -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_strtod_unbroken" >&5 -$as_echo "$tcl_cv_strtod_unbroken" >&6; } - if test "$tcl_cv_strtod_unbroken" = "ok"; then - tcl_ok=1 - else - tcl_ok=0 - fi - fi - if test "$tcl_ok" = 0; then - case " $LIBOBJS " in - *" strtod.$ac_objext "* ) ;; - *) LIBOBJS="$LIBOBJS strtod.$ac_objext" - ;; -esac - - USE_COMPAT=1 - fi - - -#-------------------------------------------------------------------- -# Under Solaris 2.4, strtod returns the wrong value for the -# terminating character under some conditions. Check for this -# and if the problem exists use a substitute procedure -# "fixstrtod" that corrects the error. -#-------------------------------------------------------------------- - - - ac_fn_c_check_func "$LINENO" "strtod" "ac_cv_func_strtod" -if test "x$ac_cv_func_strtod" = xyes; then : - tcl_strtod=1 -else - tcl_strtod=0 -fi - - if test "$tcl_strtod" = 1; then - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for Solaris2.4/Tru64 strtod bugs" >&5 -$as_echo_n "checking for Solaris2.4/Tru64 strtod bugs... " >&6; } -if ${tcl_cv_strtod_buggy+:} false; then : - $as_echo_n "(cached) " >&6 -else - - if test "$cross_compiling" = yes; then : - tcl_cv_strtod_buggy=buggy -else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - - extern double strtod(); - int main() { - char *infString="Inf", *nanString="NaN", *spaceString=" "; - char *term; - double value; - value = strtod(infString, &term); - if ((term != infString) && (term[-1] == 0)) { - exit(1); - } - value = strtod(nanString, &term); - if ((term != nanString) && (term[-1] == 0)) { - exit(1); - } - value = strtod(spaceString, &term); - if (term == (spaceString+1)) { - exit(1); - } - exit(0); - } -_ACEOF -if ac_fn_c_try_run "$LINENO"; then : - tcl_cv_strtod_buggy=ok -else - tcl_cv_strtod_buggy=buggy -fi -rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ - conftest.$ac_objext conftest.beam conftest.$ac_ext -fi - -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_strtod_buggy" >&5 -$as_echo "$tcl_cv_strtod_buggy" >&6; } - if test "$tcl_cv_strtod_buggy" = buggy; then - case " $LIBOBJS " in - *" fixstrtod.$ac_objext "* ) ;; - *) LIBOBJS="$LIBOBJS fixstrtod.$ac_objext" - ;; -esac - - USE_COMPAT=1 - -$as_echo "#define strtod fixstrtod" >>confdefs.h - - fi - fi - - -#-------------------------------------------------------------------- # Check for various typedefs and provide substitutes if # they don't exist. #-------------------------------------------------------------------- diff --git a/unix/configure.ac b/unix/configure.ac index bd8ea97..f34091f 100644 --- a/unix/configure.ac +++ b/unix/configure.ac @@ -381,26 +381,6 @@ SC_TCL_CHECK_BROKEN_FUNC(strtoul, [ ]) #-------------------------------------------------------------------- -# Check for the strtod function. This is tricky because in some -# versions of Linux strtod mis-parses strings starting with "+". -#-------------------------------------------------------------------- - -SC_TCL_CHECK_BROKEN_FUNC(strtod, [ - extern double strtod(); - char *term, *string = " +69"; - exit(strtod(string,&term) != 69 || term != string+4); -]) - -#-------------------------------------------------------------------- -# Under Solaris 2.4, strtod returns the wrong value for the -# terminating character under some conditions. Check for this -# and if the problem exists use a substitute procedure -# "fixstrtod" that corrects the error. -#-------------------------------------------------------------------- - -SC_BUGGY_STRTOD - -#-------------------------------------------------------------------- # Check for various typedefs and provide substitutes if # they don't exist. #-------------------------------------------------------------------- diff --git a/unix/tcl.m4 b/unix/tcl.m4 index e27cc2c..0426c7f 100644 --- a/unix/tcl.m4 +++ b/unix/tcl.m4 @@ -2182,59 +2182,6 @@ AC_DEFUN([SC_TIME_HANDLER], [ ]) #-------------------------------------------------------------------- -# SC_BUGGY_STRTOD -# -# Under Solaris 2.4, strtod returns the wrong value for the -# terminating character under some conditions. Check for this -# and if the problem exists use a substitute procedure -# "fixstrtod" (provided by Tcl) that corrects the error. -# Also, on Compaq's Tru64 Unix 5.0, -# strtod(" ") returns 0.0 instead of a failure to convert. -# -# Arguments: -# none -# -# Results: -# -# Might defines some of the following vars: -# strtod (=fixstrtod) -# -#-------------------------------------------------------------------- - -AC_DEFUN([SC_BUGGY_STRTOD], [ - AC_CHECK_FUNC(strtod, tcl_strtod=1, tcl_strtod=0) - if test "$tcl_strtod" = 1; then - AC_CACHE_CHECK([for Solaris2.4/Tru64 strtod bugs], tcl_cv_strtod_buggy,[ - AC_TRY_RUN([ - extern double strtod(); - int main() { - char *infString="Inf", *nanString="NaN", *spaceString=" "; - char *term; - double value; - value = strtod(infString, &term); - if ((term != infString) && (term[-1] == 0)) { - exit(1); - } - value = strtod(nanString, &term); - if ((term != nanString) && (term[-1] == 0)) { - exit(1); - } - value = strtod(spaceString, &term); - if (term == (spaceString+1)) { - exit(1); - } - exit(0); - }], tcl_cv_strtod_buggy=ok, tcl_cv_strtod_buggy=buggy, - tcl_cv_strtod_buggy=buggy)]) - if test "$tcl_cv_strtod_buggy" = buggy; then - AC_LIBOBJ([fixstrtod]) - USE_COMPAT=1 - AC_DEFINE(strtod, fixstrtod, [Do we want to use the strtod() in compat?]) - fi - fi -]) - -#-------------------------------------------------------------------- # SC_TCL_LINK_LIBS # # Search for the libraries needed to link the Tcl shell. -- cgit v0.12 From 22a5d73ebf204659f328464091641c1b71c865c1 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 29 Oct 2018 19:54:58 +0000 Subject: squelch some warnings on higher Visual Studio versions: we are not going to bother on this any more. --- win/tclWinPort.h | 2 ++ 1 file changed, 2 insertions(+) diff --git a/win/tclWinPort.h b/win/tclWinPort.h index 0f7d1fa..c30d1bd 100644 --- a/win/tclWinPort.h +++ b/win/tclWinPort.h @@ -382,6 +382,8 @@ typedef DWORD_PTR * PDWORD_PTR; #if defined(_MSC_VER) && (_MSC_VER >= 1400) # pragma warning(disable:4244) # pragma warning(disable:4267) +# pragma warning(disable:4311) +# pragma warning(disable:4312) # pragma warning(disable:4996) #endif -- cgit v0.12 From 74707353e824dd0dced5d646f6603f80e9647ae5 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 30 Oct 2018 20:39:24 +0000 Subject: Add support for TIP #494 to registry and dde. Only effective when compiled against Tcl 9.0 headers. This way we can keep the source-code for those extensions 100% equal in all branches. Work-around for gcc warning in tclWinFile.c. Discovered by Travis CI. --- win/tclWinDde.c | 26 ++++++++++++++++++++++---- win/tclWinFile.c | 9 +++++++++ win/tclWinReg.c | 23 +++++++++++++++++++++-- 3 files changed, 52 insertions(+), 6 deletions(-) diff --git a/win/tclWinDde.c b/win/tclWinDde.c index 38f1d88..27ddfc8 100644 --- a/win/tclWinDde.c +++ b/win/tclWinDde.c @@ -117,6 +117,24 @@ static int DdeObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +static unsigned char * +getByteArrayFromObj( + Tcl_Obj *objPtr, + size_t *lengthPtr +) { + int length; + + unsigned char *result = Tcl_GetByteArrayFromObj(objPtr, &length); +#if TCL_MAJOR_VERSION > 8 + if (sizeof(TCL_HASH_TYPE) > sizeof(int)) { + /* 64-bit and TIP #494 situation: */ + *lengthPtr = *(TCL_HASH_TYPE *) objPtr->internalRep.twoPtrValue.ptr1; + } else +#endif + /* 32-bit or without TIP #494 */ + *lengthPtr = (size_t) (unsigned) length; + return result; +} DLLEXPORT int Dde_Init(Tcl_Interp *interp); DLLEXPORT int Dde_SafeInit(Tcl_Interp *interp); @@ -1279,7 +1297,7 @@ DdeObjCmd( }; int index, i, argIndex; - int length; + size_t length; int flags = 0, result = TCL_OK, firstArg = 0; HSZ ddeService = NULL, ddeTopic = NULL, ddeItem = NULL, ddeCookie = NULL; HDDEDATA ddeData = NULL, ddeItemData = NULL, ddeReturn; @@ -1489,14 +1507,14 @@ DdeObjCmd( break; case DDE_EXECUTE: { - int dataLength; + size_t dataLength; const void *dataString; Tcl_DString dsBuf; Tcl_DStringInit(&dsBuf); if (flags & DDE_FLAG_BINARY) { dataString = - Tcl_GetByteArrayFromObj(objv[firstArg + 2], &dataLength); + getByteArrayFromObj(objv[firstArg + 2], &dataLength); } else { const char *src; @@ -1633,7 +1651,7 @@ DdeObjCmd( Tcl_DStringInit(&dsBuf); if (flags & DDE_FLAG_BINARY) { dataString = (BYTE *) - Tcl_GetByteArrayFromObj(objv[firstArg + 3], &length); + getByteArrayFromObj(objv[firstArg + 3], &length); } else { const char *data = Tcl_GetString(objv[firstArg + 3]); diff --git a/win/tclWinFile.c b/win/tclWinFile.c index cbd8814..8ee4bce 100755 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -569,6 +569,11 @@ TclWinSymLinkDelete( *-------------------------------------------------------------------- */ +#if defined (__clang__) || ((__GNUC__) && ((__GNUC__ > 4) || ((__GNUC__ == 4) && (__GNUC_MINOR__ > 5)))) +#pragma GCC diagnostic push +#pragma GCC diagnostic ignored "-Warray-bounds" +#endif + static Tcl_Obj * WinReadLinkDirectory( const TCHAR *linkDirPath) @@ -684,6 +689,10 @@ WinReadLinkDirectory( Tcl_SetErrno(EINVAL); return NULL; } + +#if defined (__clang__) || ((__GNUC__) && ((__GNUC__ > 4) || ((__GNUC__ == 4) && (__GNUC_MINOR__ > 5)))) +#pragma GCC diagnostic pop +#endif /* *-------------------------------------------------------------------- diff --git a/win/tclWinReg.c b/win/tclWinReg.c index 0d2cd94..f93a553 100644 --- a/win/tclWinReg.c +++ b/win/tclWinReg.c @@ -124,6 +124,25 @@ static int SetValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj, Tcl_Obj *valueNameObj, Tcl_Obj *dataObj, Tcl_Obj *typeObj, REGSAM mode); +static unsigned char * +getByteArrayFromObj( + Tcl_Obj *objPtr, + size_t *lengthPtr +) { + int length; + + unsigned char *result = Tcl_GetByteArrayFromObj(objPtr, &length); +#if TCL_MAJOR_VERSION > 8 + if (sizeof(TCL_HASH_TYPE) > sizeof(int)) { + /* 64-bit and TIP #494 situation: */ + *lengthPtr = *(TCL_HASH_TYPE *) objPtr->internalRep.twoPtrValue.ptr1; + } else +#endif + /* 32-bit or without TIP #494 */ + *lengthPtr = (size_t) (unsigned) length; + return result; +} + DLLEXPORT int Registry_Init(Tcl_Interp *interp); DLLEXPORT int Registry_Unload(Tcl_Interp *interp, int flags); @@ -1324,13 +1343,13 @@ SetValue( Tcl_DStringFree(&buf); } else { BYTE *data; - int bytelength; + size_t bytelength; /* * Store binary data in the registry. */ - data = (BYTE *) Tcl_GetByteArrayFromObj(dataObj, &bytelength); + data = (BYTE *) getByteArrayFromObj(dataObj, &bytelength); result = RegSetValueEx(key, (TCHAR *) valueName, 0, (DWORD) type, data, (DWORD) bytelength); } -- cgit v0.12 From 434a115a3c3cbd45b3e01a1af2ad1e960077a056 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 30 Oct 2018 20:40:03 +0000 Subject: Add support for DragonFly --- unix/configure | 4 ++-- unix/tcl.m4 | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/unix/configure b/unix/configure index 61d922a..1e15a25 100755 --- a/unix/configure +++ b/unix/configure @@ -7646,7 +7646,7 @@ fi fi ;; - FreeBSD-*) + DragonFly-*|FreeBSD-*) # This configuration from FreeBSD Ports. SHLIB_CFLAGS="-fPIC" SHLIB_LD="${CC} -shared" @@ -8854,7 +8854,7 @@ fi BSD/OS*) ;; CYGWIN_*|MINGW32_*) ;; IRIX*) ;; - NetBSD-*|FreeBSD-*|OpenBSD-*) ;; + NetBSD-*|DragonFly-*|FreeBSD-*|OpenBSD-*) ;; Darwin-*) ;; SCO_SV-3.2*) ;; *) SHLIB_CFLAGS="-fPIC" ;; diff --git a/unix/tcl.m4 b/unix/tcl.m4 index 99e0cbd..38f1377 100644 --- a/unix/tcl.m4 +++ b/unix/tcl.m4 @@ -1563,7 +1563,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ LDFLAGS="$LDFLAGS -pthread" ]) ;; - FreeBSD-*) + DragonFly-*|FreeBSD-*) # This configuration from FreeBSD Ports. SHLIB_CFLAGS="-fPIC" SHLIB_LD="${CC} -shared" @@ -2059,7 +2059,7 @@ dnl # preprocessing tests use only CPPFLAGS. BSD/OS*) ;; CYGWIN_*|MINGW32_*) ;; IRIX*) ;; - NetBSD-*|FreeBSD-*|OpenBSD-*) ;; + NetBSD-*|DragonFly-*|FreeBSD-*|OpenBSD-*) ;; Darwin-*) ;; SCO_SV-3.2*) ;; *) SHLIB_CFLAGS="-fPIC" ;; -- cgit v0.12 From b3dceb53606507960d33a6a90dfcb94c720ace30 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 31 Oct 2018 21:02:42 +0000 Subject: Make MacOSX compile work (hopefully) and cross-compile on mingw-w64 (compile only, no unit-test yet) --- .travis.yml | 82 ++++++++++++++++++++++++++++++++++++++++++++++++++----------- 1 file changed, 68 insertions(+), 14 deletions(-) diff --git a/.travis.yml b/.travis.yml index 0f8af5a..64801ec 100644 --- a/.travis.yml +++ b/.travis.yml @@ -6,19 +6,25 @@ matrix: - os: linux compiler: clang env: - - MATRIX_EVAL="" BUILD_DIR=unix + - MATRIX_EVAL="" + - BUILD_DIR=unix - os: linux compiler: clang env: - - MATRIX_EVAL="" BUILD_DIR=unix CFGOPT=--disable-shared + - MATRIX_EVAL="" + - BUILD_DIR=unix + - CFGOPT=--disable-shared - os: linux compiler: gcc env: - - MATRIX_EVAL="" BUILD_DIR=unix + - MATRIX_EVAL="" + - BUILD_DIR=unix - os: linux compiler: gcc env: - - MATRIX_EVAL="" BUILD_DIR=unix CFGOPT=--disable-shared + - MATRIX_EVAL="" + - BUILD_DIR=unix + - CFGOPT=--disable-shared - os: linux compiler: gcc addons: @@ -28,7 +34,8 @@ matrix: packages: - g++-4.9 env: - - MATRIX_EVAL="CC=gcc-4.9" BUILD_DIR=unix + - MATRIX_EVAL="CC=gcc-4.9" + - BUILD_DIR=unix - os: linux compiler: gcc addons: @@ -38,7 +45,8 @@ matrix: packages: - g++-5 env: - - MATRIX_EVAL="CC=gcc-5" BUILD_DIR=unix + - MATRIX_EVAL="CC=gcc-5" + - BUILD_DIR=unix - os: linux compiler: gcc addons: @@ -48,7 +56,8 @@ matrix: packages: - g++-6 env: - - MATRIX_EVAL="CC=gcc-6" BUILD_DIR=unix + - MATRIX_EVAL="CC=gcc-6" + - BUILD_DIR=unix - os: linux compiler: gcc addons: @@ -58,29 +67,74 @@ matrix: packages: - g++-7 env: - - MATRIX_EVAL="CC=gcc-7" BUILD_DIR=unix + - MATRIX_EVAL="CC=gcc-7" + - BUILD_DIR=unix - os: osx osx_image: xcode8 env: - - MATRIX_EVAL="" BUILD_DIR=unix + - MATRIX_EVAL="" + - BUILD_DIR=unix - os: osx osx_image: xcode8 env: - - MATRIX_EVAL="" BUILD_DIR=macosx NO_DIRECT_CONFIGURE=1 + - MATRIX_EVAL="" + - BUILD_DIR=macosx + - NO_DIRECT_CONFIGURE=1 - os: osx osx_image: xcode9 env: - - MATRIX_EVAL="" BUILD_DIR=macosx NO_DIRECT_CONFIGURE=1 + - MATRIX_EVAL="" + - BUILD_DIR=macosx + - NO_DIRECT_CONFIGURE=1 - os: osx osx_image: xcode10 env: - - MATRIX_EVAL="" BUILD_DIR=macosx NO_DIRECT_CONFIGURE=1 + - MATRIX_EVAL="" + - BUILD_DIR=macosx + - NO_DIRECT_CONFIGURE=1 +# Test with mingw-w64 (32 bit) + - os: linux + compiler: i686-w64-mingw32-gcc + addons: + apt: + packages: + - gcc-mingw-w64-base + - binutils-mingw-w64-i686 + - gcc-mingw-w64-i686 + - gcc-mingw-w64 + - gcc-multilib + - wine + env: + - MATRIX_EVAL="" + - BUILD_DIR=win + - CFGOPT=--host=i686-w64-mingw32 + - NO_DIRECT_TEST=1 + +# Test with mingw-w64 (64 bit) + - os: linux + compiler: x86_64-w64-mingw32-gcc + addons: + apt: + packages: + - gcc-mingw-w64-base + - binutils-mingw-w64-x86-64 + - gcc-mingw-w64-x86-64 + - gcc-mingw-w64 + - wine + env: + - MATRIX_EVAL="" + - BUILD_DIR=win + - CFGOPT=--host=x86_64-w64-mingw32 --enable-64bit + - NO_DIRECT_TEST=1 + ### C builds not currently supported on Windows instances # - os: windows # env: -# - MATRIX_EVAL="" BUILD_DIR=win +# - MATRIX_EVAL="" +# - BUILD_DIR=win before_install: + - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then rvm get stable; fi - eval "${MATRIX_EVAL}" - export ERROR_ON_FAILURES=1 - cd ${BUILD_DIR} @@ -88,4 +142,4 @@ install: - test -n "$NO_DIRECT_CONFIGURE" || ./configure ${CFGOPT} script: - make - - make test + - test -n "$NO_DIRECT_TEST" || make test -- cgit v0.12 From a0c7ff582a10cc77bd4f95cf577516beeb416ce5 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 1 Nov 2018 14:46:07 +0000 Subject: Eliminate fallback attempts when broken strtod() routines are detected. This has long been creating more problems than it solves. --- compat/fixstrtod.c | 36 ------ compat/stdlib.h | 1 - compat/strtod.c | 252 -------------------------------------- unix/Makefile.in | 6 - unix/configure | 352 ----------------------------------------------------- unix/configure.in | 20 --- unix/tcl.m4 | 53 -------- 7 files changed, 720 deletions(-) delete mode 100644 compat/fixstrtod.c delete mode 100644 compat/strtod.c diff --git a/compat/fixstrtod.c b/compat/fixstrtod.c deleted file mode 100644 index 63fb8ef..0000000 --- a/compat/fixstrtod.c +++ /dev/null @@ -1,36 +0,0 @@ -/* - * fixstrtod.c -- - * - * Source code for the "fixstrtod" procedure. This procedure is - * used in place of strtod under Solaris 2.4, in order to fix - * a bug where the "end" pointer gets set incorrectly. - * - * Copyright (c) 1995 Sun Microsystems, Inc. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - */ - -#include - -#undef strtod - -/* - * Declare strtod explicitly rather than including stdlib.h, since in - * somes systems (e.g. SunOS 4.1.4) stdlib.h doesn't declare strtod. - */ - -extern double strtod(char *, char **); - -double -fixstrtod( - char *string, - char **endPtr) -{ - double d; - d = strtod(string, endPtr); - if ((endPtr != NULL) && (*endPtr != string) && ((*endPtr)[-1] == 0)) { - *endPtr -= 1; - } - return d; -} diff --git a/compat/stdlib.h b/compat/stdlib.h index 0ad4c1d..6900be3 100644 --- a/compat/stdlib.h +++ b/compat/stdlib.h @@ -29,7 +29,6 @@ extern char * malloc(unsigned int numBytes); extern void qsort(void *base, int n, int size, int (*compar)( const void *element1, const void *element2)); extern char * realloc(char *ptr, unsigned int numBytes); -extern double strtod(const char *string, char **endPtr); extern long strtol(const char *string, char **endPtr, int base); extern unsigned long strtoul(const char *string, char **endPtr, int base); diff --git a/compat/strtod.c b/compat/strtod.c deleted file mode 100644 index 9643c09..0000000 --- a/compat/strtod.c +++ /dev/null @@ -1,252 +0,0 @@ -/* - * strtod.c -- - * - * Source code for the "strtod" library procedure. - * - * Copyright (c) 1988-1993 The Regents of the University of California. - * Copyright (c) 1994 Sun Microsystems, Inc. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - */ - -#include "tclInt.h" - -#ifndef TRUE -#define TRUE 1 -#define FALSE 0 -#endif -#ifndef NULL -#define NULL 0 -#endif - -static const int maxExponent = 511; /* Largest possible base 10 exponent. Any - * exponent larger than this will already - * produce underflow or overflow, so there's - * no need to worry about additional digits. - */ -static const double powersOf10[] = { /* Table giving binary powers of 10. Entry */ - 10., /* is 10^2^i. Used to convert decimal */ - 100., /* exponents into floating-point numbers. */ - 1.0e4, - 1.0e8, - 1.0e16, - 1.0e32, - 1.0e64, - 1.0e128, - 1.0e256 -}; - -/* - *---------------------------------------------------------------------- - * - * strtod -- - * - * This procedure converts a floating-point number from an ASCII - * decimal representation to internal double-precision format. - * - * Results: - * The return value is the double-precision floating-point - * representation of the characters in string. If endPtr isn't - * NULL, then *endPtr is filled in with the address of the - * next character after the last one that was part of the - * floating-point number. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -double -strtod( - const char *string, /* A decimal ASCII floating-point number, - * optionally preceded by white space. Must - * have form "-I.FE-X", where I is the integer - * part of the mantissa, F is the fractional - * part of the mantissa, and X is the - * exponent. Either of the signs may be "+", - * "-", or omitted. Either I or F may be - * omitted, or both. The decimal point isn't - * necessary unless F is present. The "E" may - * actually be an "e". E and X may both be - * omitted (but not just one). */ - char **endPtr) /* If non-NULL, store terminating character's - * address here. */ -{ - int sign, expSign = FALSE; - double fraction, dblExp; - const double *d; - register const char *p; - register int c; - int exp = 0; /* Exponent read from "EX" field. */ - int fracExp = 0; /* Exponent that derives from the fractional - * part. Under normal circumstatnces, it is - * the negative of the number of digits in F. - * However, if I is very long, the last digits - * of I get dropped (otherwise a long I with a - * large negative exponent could cause an - * unnecessary overflow on I alone). In this - * case, fracExp is incremented one for each - * dropped digit. */ - int mantSize; /* Number of digits in mantissa. */ - int decPt; /* Number of mantissa digits BEFORE decimal - * point. */ - const char *pExp; /* Temporarily holds location of exponent in - * string. */ - - /* - * Strip off leading blanks and check for a sign. - */ - - p = string; - while (isspace(UCHAR(*p))) { - p += 1; - } - if (*p == '-') { - sign = TRUE; - p += 1; - } else { - if (*p == '+') { - p += 1; - } - sign = FALSE; - } - - /* - * Count the number of digits in the mantissa (including the decimal - * point), and also locate the decimal point. - */ - - decPt = -1; - for (mantSize = 0; ; mantSize += 1) - { - c = *p; - if (!isdigit(c)) { - if ((c != '.') || (decPt >= 0)) { - break; - } - decPt = mantSize; - } - p += 1; - } - - /* - * Now suck up the digits in the mantissa. Use two integers to collect 9 - * digits each (this is faster than using floating-point). If the mantissa - * has more than 18 digits, ignore the extras, since they can't affect the - * value anyway. - */ - - pExp = p; - p -= mantSize; - if (decPt < 0) { - decPt = mantSize; - } else { - mantSize -= 1; /* One of the digits was the point. */ - } - if (mantSize > 18) { - fracExp = decPt - 18; - mantSize = 18; - } else { - fracExp = decPt - mantSize; - } - if (mantSize == 0) { - fraction = 0.0; - p = string; - goto done; - } else { - int frac1, frac2; - - frac1 = 0; - for ( ; mantSize > 9; mantSize -= 1) { - c = *p; - p += 1; - if (c == '.') { - c = *p; - p += 1; - } - frac1 = 10*frac1 + (c - '0'); - } - frac2 = 0; - for (; mantSize > 0; mantSize -= 1) { - c = *p; - p += 1; - if (c == '.') { - c = *p; - p += 1; - } - frac2 = 10*frac2 + (c - '0'); - } - fraction = (1.0e9 * frac1) + frac2; - } - - /* - * Skim off the exponent. - */ - - p = pExp; - if ((*p == 'E') || (*p == 'e')) { - p += 1; - if (*p == '-') { - expSign = TRUE; - p += 1; - } else { - if (*p == '+') { - p += 1; - } - expSign = FALSE; - } - if (!isdigit(UCHAR(*p))) { - p = pExp; - goto done; - } - while (isdigit(UCHAR(*p))) { - exp = exp * 10 + (*p - '0'); - p += 1; - } - } - if (expSign) { - exp = fracExp - exp; - } else { - exp = fracExp + exp; - } - - /* - * Generate a floating-point number that represents the exponent. Do this - * by processing the exponent one bit at a time to combine many powers of - * 2 of 10. Then combine the exponent with the fraction. - */ - - if (exp < 0) { - expSign = TRUE; - exp = -exp; - } else { - expSign = FALSE; - } - if (exp > maxExponent) { - exp = maxExponent; - errno = ERANGE; - } - dblExp = 1.0; - for (d = powersOf10; exp != 0; exp >>= 1, ++d) { - if (exp & 01) { - dblExp *= *d; - } - } - if (expSign) { - fraction /= dblExp; - } else { - fraction *= dblExp; - } - - done: - if (endPtr != NULL) { - *endPtr = (char *) p; - } - - if (sign) { - return -fraction; - } - return fraction; -} diff --git a/unix/Makefile.in b/unix/Makefile.in index 66114ba..aaff7ae 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -1632,9 +1632,6 @@ tclXtTest.o: $(UNIX_DIR)/tclXtTest.c # relocatable. #-------------------------------------------------------------------------- -fixstrtod.o: $(COMPAT_DIR)/fixstrtod.c - $(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/fixstrtod.c - opendir.o: $(COMPAT_DIR)/opendir.c $(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/opendir.c @@ -1650,9 +1647,6 @@ strncasecmp.o: $(COMPAT_DIR)/strncasecmp.c strstr.o: $(COMPAT_DIR)/strstr.c $(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/strstr.c -strtod.o: $(COMPAT_DIR)/strtod.c - $(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/strtod.c - strtol.o: $(COMPAT_DIR)/strtol.c $(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/strtol.c diff --git a/unix/configure b/unix/configure index f254ca4..c8453a8 100755 --- a/unix/configure +++ b/unix/configure @@ -14983,358 +14983,6 @@ esac #-------------------------------------------------------------------- -# Check for the strtod function. This is tricky because in some -# versions of Linux strtod mis-parses strings starting with "+". -#-------------------------------------------------------------------- - - - echo "$as_me:$LINENO: checking for strtod" >&5 -echo $ECHO_N "checking for strtod... $ECHO_C" >&6 -if test "${ac_cv_func_strtod+set}" = set; then - echo $ECHO_N "(cached) $ECHO_C" >&6 -else - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ -/* Define strtod to an innocuous variant, in case declares strtod. - For example, HP-UX 11i declares gettimeofday. */ -#define strtod innocuous_strtod - -/* System header to define __stub macros and hopefully few prototypes, - which can conflict with char strtod (); below. - Prefer to if __STDC__ is defined, since - exists even on freestanding compilers. */ - -#ifdef __STDC__ -# include -#else -# include -#endif - -#undef strtod - -/* Override any gcc2 internal prototype to avoid an error. */ -#ifdef __cplusplus -extern "C" -{ -#endif -/* We use char because int might match the return type of a gcc2 - builtin and then its argument prototype would still apply. */ -char strtod (); -/* The GNU C library defines this for functions which it implements - to always fail with ENOSYS. Some functions are actually named - something starting with __ and the normal name is an alias. */ -#if defined (__stub_strtod) || defined (__stub___strtod) -choke me -#else -char (*f) () = strtod; -#endif -#ifdef __cplusplus -} -#endif - -int -main () -{ -return f != strtod; - ; - return 0; -} -_ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; } && - { ac_try='test -s conftest$ac_exeext' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; }; then - ac_cv_func_strtod=yes -else - echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - -ac_cv_func_strtod=no -fi -rm -f conftest.err conftest.$ac_objext \ - conftest$ac_exeext conftest.$ac_ext -fi -echo "$as_me:$LINENO: result: $ac_cv_func_strtod" >&5 -echo "${ECHO_T}$ac_cv_func_strtod" >&6 -if test $ac_cv_func_strtod = yes; then - tcl_ok=1 -else - tcl_ok=0 -fi - - if test "$tcl_ok" = 1; then - echo "$as_me:$LINENO: checking proper strtod implementation" >&5 -echo $ECHO_N "checking proper strtod implementation... $ECHO_C" >&6 -if test "${tcl_cv_strtod_unbroken+set}" = set; then - echo $ECHO_N "(cached) $ECHO_C" >&6 -else - if test "$cross_compiling" = yes; then - tcl_cv_strtod_unbroken=unknown -else - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ -int main() { - extern double strtod(); - char *term, *string = " +69"; - exit(strtod(string,&term) != 69 || term != string+4); -} -_ACEOF -rm -f conftest$ac_exeext -if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { ac_try='./conftest$ac_exeext' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; }; then - tcl_cv_strtod_unbroken=ok -else - echo "$as_me: program exited with status $ac_status" >&5 -echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - -( exit $ac_status ) -tcl_cv_strtod_unbroken=broken -fi -rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext -fi -fi -echo "$as_me:$LINENO: result: $tcl_cv_strtod_unbroken" >&5 -echo "${ECHO_T}$tcl_cv_strtod_unbroken" >&6 - if test "$tcl_cv_strtod_unbroken" = "ok"; then - tcl_ok=1 - else - tcl_ok=0 - fi - fi - if test "$tcl_ok" = 0; then - case $LIBOBJS in - "strtod.$ac_objext" | \ - *" strtod.$ac_objext" | \ - "strtod.$ac_objext "* | \ - *" strtod.$ac_objext "* ) ;; - *) LIBOBJS="$LIBOBJS strtod.$ac_objext" ;; -esac - - USE_COMPAT=1 - fi - - -#-------------------------------------------------------------------- -# Under Solaris 2.4, strtod returns the wrong value for the -# terminating character under some conditions. Check for this -# and if the problem exists use a substitute procedure -# "fixstrtod" that corrects the error. -#-------------------------------------------------------------------- - - - echo "$as_me:$LINENO: checking for strtod" >&5 -echo $ECHO_N "checking for strtod... $ECHO_C" >&6 -if test "${ac_cv_func_strtod+set}" = set; then - echo $ECHO_N "(cached) $ECHO_C" >&6 -else - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ -/* Define strtod to an innocuous variant, in case declares strtod. - For example, HP-UX 11i declares gettimeofday. */ -#define strtod innocuous_strtod - -/* System header to define __stub macros and hopefully few prototypes, - which can conflict with char strtod (); below. - Prefer to if __STDC__ is defined, since - exists even on freestanding compilers. */ - -#ifdef __STDC__ -# include -#else -# include -#endif - -#undef strtod - -/* Override any gcc2 internal prototype to avoid an error. */ -#ifdef __cplusplus -extern "C" -{ -#endif -/* We use char because int might match the return type of a gcc2 - builtin and then its argument prototype would still apply. */ -char strtod (); -/* The GNU C library defines this for functions which it implements - to always fail with ENOSYS. Some functions are actually named - something starting with __ and the normal name is an alias. */ -#if defined (__stub_strtod) || defined (__stub___strtod) -choke me -#else -char (*f) () = strtod; -#endif -#ifdef __cplusplus -} -#endif - -int -main () -{ -return f != strtod; - ; - return 0; -} -_ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; } && - { ac_try='test -s conftest$ac_exeext' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; }; then - ac_cv_func_strtod=yes -else - echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - -ac_cv_func_strtod=no -fi -rm -f conftest.err conftest.$ac_objext \ - conftest$ac_exeext conftest.$ac_ext -fi -echo "$as_me:$LINENO: result: $ac_cv_func_strtod" >&5 -echo "${ECHO_T}$ac_cv_func_strtod" >&6 -if test $ac_cv_func_strtod = yes; then - tcl_strtod=1 -else - tcl_strtod=0 -fi - - if test "$tcl_strtod" = 1; then - echo "$as_me:$LINENO: checking for Solaris2.4/Tru64 strtod bugs" >&5 -echo $ECHO_N "checking for Solaris2.4/Tru64 strtod bugs... $ECHO_C" >&6 -if test "${tcl_cv_strtod_buggy+set}" = set; then - echo $ECHO_N "(cached) $ECHO_C" >&6 -else - - if test "$cross_compiling" = yes; then - tcl_cv_strtod_buggy=buggy -else - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ - - extern double strtod(); - int main() { - char *infString="Inf", *nanString="NaN", *spaceString=" "; - char *term; - double value; - value = strtod(infString, &term); - if ((term != infString) && (term[-1] == 0)) { - exit(1); - } - value = strtod(nanString, &term); - if ((term != nanString) && (term[-1] == 0)) { - exit(1); - } - value = strtod(spaceString, &term); - if (term == (spaceString+1)) { - exit(1); - } - exit(0); - } -_ACEOF -rm -f conftest$ac_exeext -if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { ac_try='./conftest$ac_exeext' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; }; then - tcl_cv_strtod_buggy=ok -else - echo "$as_me: program exited with status $ac_status" >&5 -echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - -( exit $ac_status ) -tcl_cv_strtod_buggy=buggy -fi -rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext -fi -fi -echo "$as_me:$LINENO: result: $tcl_cv_strtod_buggy" >&5 -echo "${ECHO_T}$tcl_cv_strtod_buggy" >&6 - if test "$tcl_cv_strtod_buggy" = buggy; then - case $LIBOBJS in - "fixstrtod.$ac_objext" | \ - *" fixstrtod.$ac_objext" | \ - "fixstrtod.$ac_objext "* | \ - *" fixstrtod.$ac_objext "* ) ;; - *) LIBOBJS="$LIBOBJS fixstrtod.$ac_objext" ;; -esac - - USE_COMPAT=1 - -cat >>confdefs.h <<\_ACEOF -#define strtod fixstrtod -_ACEOF - - fi - fi - - -#-------------------------------------------------------------------- # Check for various typedefs and provide substitutes if # they don't exist. #-------------------------------------------------------------------- diff --git a/unix/configure.in b/unix/configure.in index bfa2ef7..5ecd886 100644 --- a/unix/configure.in +++ b/unix/configure.in @@ -359,26 +359,6 @@ SC_TCL_CHECK_BROKEN_FUNC(strtoul, [ ]) #-------------------------------------------------------------------- -# Check for the strtod function. This is tricky because in some -# versions of Linux strtod mis-parses strings starting with "+". -#-------------------------------------------------------------------- - -SC_TCL_CHECK_BROKEN_FUNC(strtod, [ - extern double strtod(); - char *term, *string = " +69"; - exit(strtod(string,&term) != 69 || term != string+4); -]) - -#-------------------------------------------------------------------- -# Under Solaris 2.4, strtod returns the wrong value for the -# terminating character under some conditions. Check for this -# and if the problem exists use a substitute procedure -# "fixstrtod" that corrects the error. -#-------------------------------------------------------------------- - -SC_BUGGY_STRTOD - -#-------------------------------------------------------------------- # Check for various typedefs and provide substitutes if # they don't exist. #-------------------------------------------------------------------- diff --git a/unix/tcl.m4 b/unix/tcl.m4 index ed11f9b..1953798 100644 --- a/unix/tcl.m4 +++ b/unix/tcl.m4 @@ -2398,59 +2398,6 @@ AC_DEFUN([SC_TIME_HANDLER], [ ]) #-------------------------------------------------------------------- -# SC_BUGGY_STRTOD -# -# Under Solaris 2.4, strtod returns the wrong value for the -# terminating character under some conditions. Check for this -# and if the problem exists use a substitute procedure -# "fixstrtod" (provided by Tcl) that corrects the error. -# Also, on Compaq's Tru64 Unix 5.0, -# strtod(" ") returns 0.0 instead of a failure to convert. -# -# Arguments: -# none -# -# Results: -# -# Might defines some of the following vars: -# strtod (=fixstrtod) -# -#-------------------------------------------------------------------- - -AC_DEFUN([SC_BUGGY_STRTOD], [ - AC_CHECK_FUNC(strtod, tcl_strtod=1, tcl_strtod=0) - if test "$tcl_strtod" = 1; then - AC_CACHE_CHECK([for Solaris2.4/Tru64 strtod bugs], tcl_cv_strtod_buggy,[ - AC_TRY_RUN([ - extern double strtod(); - int main() { - char *infString="Inf", *nanString="NaN", *spaceString=" "; - char *term; - double value; - value = strtod(infString, &term); - if ((term != infString) && (term[-1] == 0)) { - exit(1); - } - value = strtod(nanString, &term); - if ((term != nanString) && (term[-1] == 0)) { - exit(1); - } - value = strtod(spaceString, &term); - if (term == (spaceString+1)) { - exit(1); - } - exit(0); - }], tcl_cv_strtod_buggy=ok, tcl_cv_strtod_buggy=buggy, - tcl_cv_strtod_buggy=buggy)]) - if test "$tcl_cv_strtod_buggy" = buggy; then - AC_LIBOBJ([fixstrtod]) - USE_COMPAT=1 - AC_DEFINE(strtod, fixstrtod, [Do we want to use the strtod() in compat?]) - fi - fi -]) - -#-------------------------------------------------------------------- # SC_TCL_LINK_LIBS # # Search for the libraries needed to link the Tcl shell. -- cgit v0.12 From c65da32867fe25ae30a26d154a5a637c734de0c1 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 1 Nov 2018 15:26:12 +0000 Subject: update changes --- changes | 3 +++ 1 file changed, 3 insertions(+) diff --git a/changes b/changes index aa794ed..7800289 100644 --- a/changes +++ b/changes @@ -8886,4 +8886,7 @@ improvements to regexp engine from Postgres (lane,porter,fellows,seltenreich) 2018-10-27 tzdata updated to Olson's tzdata2017g (jima) +2018-10-29 Update tcltest package for Travis support (fellows) +=> tcltest 2.5.0 + - Released 8.6.9, November 9, 2018 - http://core.tcl-lang.org/tcl/ for details - -- cgit v0.12 From 2577d3bd45bdf3d447208afa35b8610bd48d0674 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 1 Nov 2018 16:31:00 +0000 Subject: make dist --- unix/tclConfig.h.in | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) diff --git a/unix/tclConfig.h.in b/unix/tclConfig.h.in index 1721a84..a26a48f 100644 --- a/unix/tclConfig.h.in +++ b/unix/tclConfig.h.in @@ -31,6 +31,9 @@ /* Is the cpuid instruction usable? */ #undef HAVE_CPUID +/* Is 'DIR64' in ? */ +#undef HAVE_DIR64 + /* Define to 1 if you have the `freeaddrinfo' function. */ #undef HAVE_FREEADDRINFO @@ -196,9 +199,6 @@ /* Is 'struct dirent64' in ? */ #undef HAVE_STRUCT_DIRENT64 -/* Is 'DIR64' in ? */ -#undef HAVE_DIR64 - /* Define to 1 if the system has the type `struct in6_addr'. */ #undef HAVE_STRUCT_IN6_ADDR @@ -496,9 +496,6 @@ /* Define as int if socklen_t is not available */ #undef socklen_t -/* Do we want to use the strtod() in compat? */ -#undef strtod - /* Define to `int' if doesn't define. */ #undef uid_t -- cgit v0.12 From d739e9b6a832caa5729f3d77aaf3017b0c1fb867 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Thu, 1 Nov 2018 20:10:06 +0000 Subject: Fixed memory leak in TclOO.c:ObjectNamespaceDeleted, object mixins and object/class mutation. --- generic/tclOO.c | 9 +++++++-- generic/tclOODefineCmds.c | 2 ++ 2 files changed, 9 insertions(+), 2 deletions(-) diff --git a/generic/tclOO.c b/generic/tclOO.c index 2491c2f..01be0fc 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -1057,7 +1057,6 @@ TclOOReleaseClassContents( if (IsRootClass(oPtr) && !Deleted(fPtr->objectCls->thisPtr)) { Tcl_DeleteCommandFromToken(interp, fPtr->objectCls->thisPtr->command); } - oPtr->classPtr = NULL; } /* @@ -1183,7 +1182,9 @@ ObjectNamespaceDeleted( TclOORemoveFromInstances(oPtr, mixinPtr); TclOODecrRefCount(mixinPtr->thisPtr); } - ckfree(oPtr->mixins.list); + if (oPtr->mixins.list != NULL) { + ckfree(oPtr->mixins.list); + } } FOREACH(filterObj, oPtr->filters) { @@ -1384,6 +1385,10 @@ TclOORemoveFromMixins( break; } } + if (oPtr->mixins.num == 0) { + ckfree(oPtr->mixins.list); + oPtr->mixins.list = NULL; + } return res; } diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index b4ff283..3e8dd11 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -1449,6 +1449,8 @@ TclOODefineClassObjCmd( TclOODeleteDescendants(interp, oPtr); oPtr->flags &= ~DONT_DELETE; TclOOReleaseClassContents(interp, oPtr); + ckfree(oPtr->classPtr); + oPtr->classPtr = NULL; } else if (!wasClass && willBeClass) { TclOOAllocClass(interp, oPtr); } -- cgit v0.12 From e2d299f77176b587e8995a54587bddf210af6560 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 2 Nov 2018 17:18:57 +0000 Subject: Fixed memory leak in TclOO.c:ObjectNamespaceDeleted, object mixins and object/class mutation. --- generic/tclOO.c | 9 +++++++-- generic/tclOODefineCmds.c | 2 ++ 2 files changed, 9 insertions(+), 2 deletions(-) diff --git a/generic/tclOO.c b/generic/tclOO.c index 573df3e..39d3806 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -1035,7 +1035,6 @@ TclOOReleaseClassContents( if (IsRootClass(oPtr) && !Deleted(fPtr->objectCls->thisPtr)) { Tcl_DeleteCommandFromToken(interp, fPtr->objectCls->thisPtr->command); } - oPtr->classPtr = NULL; } /* @@ -1149,7 +1148,9 @@ ObjectNamespaceDeleted( TclOORemoveFromInstances(oPtr, mixinPtr); TclOODecrRefCount(mixinPtr->thisPtr); } - ckfree(oPtr->mixins.list); + if (oPtr->mixins.list != NULL) { + ckfree(oPtr->mixins.list); + } } FOREACH(filterObj, oPtr->filters) { @@ -1350,6 +1351,10 @@ TclOORemoveFromMixins( break; } } + if (oPtr->mixins.num == 0) { + ckfree(oPtr->mixins.list); + oPtr->mixins.list = NULL; + } return res; } diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index d5f4878..0271a43 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -1157,6 +1157,8 @@ TclOODefineClassObjCmd( TclOODeleteDescendants(interp, oPtr); oPtr->flags &= ~DONT_DELETE; TclOOReleaseClassContents(interp, oPtr); + ckfree(oPtr->classPtr); + oPtr->classPtr = NULL; } else if (!wasClass && willBeClass) { TclOOAllocClass(interp, oPtr); } -- cgit v0.12 From 3c18b618a5de7f396b11b724cd1dae4546c858b7 Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 6 Nov 2018 10:08:11 +0000 Subject: Added documentation --- doc/string.n | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) diff --git a/doc/string.n b/doc/string.n index 439f3b7..cc3fc54 100644 --- a/doc/string.n +++ b/doc/string.n @@ -20,7 +20,7 @@ Performs one of several string operations, depending on \fIoption\fR. The legal \fIoption\fRs (which may be abbreviated) are: .TP \fBstring cat\fR ?\fIstring1\fR? ?\fIstring2...\fR? -.VS 8.6.2 +. Concatenate the given \fIstring\fRs just like placing them directly next to each other and return the resulting compound string. If no \fIstring\fRs are present, the result is an empty string. @@ -32,7 +32,6 @@ of a concatenation without resorting to \fBreturn\fR \fB\-level 0\fR, and is more efficient than building a list of arguments and using \fBjoin\fR with an empty join string. .RE -.VE .TP \fBstring compare\fR ?\fB\-nocase\fR? ?\fB\-length\fI length\fR? \fIstring1 string2\fR . @@ -111,17 +110,24 @@ Any character with a value less than \eu0080 (those that are in the Any of the forms allowed to \fBTcl_GetBoolean\fR. .IP \fBcontrol\fR 12 Any Unicode control character. +.IP \fBdict\fR 12 +.VS TIP501 +Any proper dict structure, with optional surrounding whitespace. In +case of improper dict structure, 0 is returned and the \fIvarname\fR +will contain the index of the +.QW element +where the dict parsing fails, or \-1 if this cannot be determined. +.VE TIP501 .IP \fBdigit\fR 12 Any Unicode digit character. Note that this includes characters outside of the [0\-9] range. .IP \fBdouble\fR 12 Any of the forms allowed to \fBTcl_GetDoubleFromObj\fR. .IP \fBentier\fR 12 -.VS 8.6 +. Any of the valid string formats for an integer value of arbitrary size in Tcl, with optional surrounding whitespace. The formats accepted are exactly those accepted by the C routine \fBTcl_GetBignumFromObj\fR. -.VE .IP \fBfalse\fR 12 Any of the forms allowed to \fBTcl_GetBoolean\fR where the value is false. -- cgit v0.12 -- cgit v0.12 From 29a883d89f7bd839ee9091bb1b462dfcd0df8341 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 7 Nov 2018 08:58:01 +0000 Subject: Fix "executable" flag for many files (now really!) --- compat/zlib/win32/zlib1.dll | Bin compat/zlib/win64/zlib1.dll | Bin compat/zlib/zlib2ansi | 0 doc/GetCwd.3 | 0 doc/GetVersion.3 | 0 doc/lset.n | 0 generic/tclStrToD.c | 0 library/clock.tcl | 0 library/encoding/tis-620.enc | 0 library/msgs/af.msg | 0 library/msgs/af_za.msg | 0 library/msgs/ar.msg | 0 library/msgs/ar_in.msg | 0 library/msgs/ar_jo.msg | 0 library/msgs/ar_lb.msg | 0 library/msgs/ar_sy.msg | 0 library/msgs/be.msg | 0 library/msgs/bg.msg | 0 library/msgs/bn.msg | 0 library/msgs/bn_in.msg | 0 library/msgs/ca.msg | 0 library/msgs/cs.msg | 0 library/msgs/da.msg | 0 library/msgs/de.msg | 0 library/msgs/de_at.msg | 0 library/msgs/de_be.msg | 0 library/msgs/el.msg | 0 library/msgs/en_au.msg | 0 library/msgs/en_be.msg | 0 library/msgs/en_bw.msg | 0 library/msgs/en_ca.msg | 0 library/msgs/en_gb.msg | 0 library/msgs/en_hk.msg | 0 library/msgs/en_ie.msg | 0 library/msgs/en_in.msg | 0 library/msgs/en_nz.msg | 0 library/msgs/en_ph.msg | 0 library/msgs/en_sg.msg | 0 library/msgs/en_za.msg | 0 library/msgs/en_zw.msg | 0 library/msgs/eo.msg | 0 library/msgs/es.msg | 0 library/msgs/es_ar.msg | 0 library/msgs/es_bo.msg | 0 library/msgs/es_cl.msg | 0 library/msgs/es_co.msg | 0 library/msgs/es_cr.msg | 0 library/msgs/es_do.msg | 0 library/msgs/es_ec.msg | 0 library/msgs/es_gt.msg | 0 library/msgs/es_hn.msg | 0 library/msgs/es_mx.msg | 0 library/msgs/es_ni.msg | 0 library/msgs/es_pa.msg | 0 library/msgs/es_pe.msg | 0 library/msgs/es_pr.msg | 0 library/msgs/es_py.msg | 0 library/msgs/es_sv.msg | 0 library/msgs/es_uy.msg | 0 library/msgs/es_ve.msg | 0 library/msgs/et.msg | 0 library/msgs/eu.msg | 0 library/msgs/eu_es.msg | 0 library/msgs/fa.msg | 0 library/msgs/fa_in.msg | 0 library/msgs/fa_ir.msg | 0 library/msgs/fi.msg | 0 library/msgs/fo.msg | 0 library/msgs/fo_fo.msg | 0 library/msgs/fr.msg | 0 library/msgs/fr_be.msg | 0 library/msgs/fr_ca.msg | 0 library/msgs/fr_ch.msg | 0 library/msgs/ga.msg | 0 library/msgs/ga_ie.msg | 0 library/msgs/gl.msg | 0 library/msgs/gl_es.msg | 0 library/msgs/gv.msg | 0 library/msgs/gv_gb.msg | 0 library/msgs/he.msg | 0 library/msgs/hi.msg | 0 library/msgs/hi_in.msg | 0 library/msgs/hr.msg | 0 library/msgs/hu.msg | 0 library/msgs/id.msg | 0 library/msgs/id_id.msg | 0 library/msgs/is.msg | 0 library/msgs/it.msg | 0 library/msgs/it_ch.msg | 0 library/msgs/ja.msg | 0 library/msgs/kl.msg | 0 library/msgs/kl_gl.msg | 0 library/msgs/ko.msg | 0 library/msgs/ko_kr.msg | 0 library/msgs/kok.msg | 0 library/msgs/kok_in.msg | 0 library/msgs/kw.msg | 0 library/msgs/kw_gb.msg | 0 library/msgs/lt.msg | 0 library/msgs/lv.msg | 0 library/msgs/mk.msg | 0 library/msgs/mr.msg | 0 library/msgs/mr_in.msg | 0 library/msgs/ms.msg | 0 library/msgs/ms_my.msg | 0 library/msgs/mt.msg | 0 library/msgs/nb.msg | 0 library/msgs/nl.msg | 0 library/msgs/nl_be.msg | 0 library/msgs/nn.msg | 0 library/msgs/pl.msg | 0 library/msgs/pt.msg | 0 library/msgs/pt_br.msg | 0 library/msgs/ro.msg | 0 library/msgs/ru.msg | 0 library/msgs/ru_ua.msg | 0 library/msgs/sh.msg | 0 library/msgs/sk.msg | 0 library/msgs/sl.msg | 0 library/msgs/sq.msg | 0 library/msgs/sr.msg | 0 library/msgs/sv.msg | 0 library/msgs/sw.msg | 0 library/msgs/ta.msg | 0 library/msgs/ta_in.msg | 0 library/msgs/te.msg | 0 library/msgs/te_in.msg | 0 library/msgs/th.msg | 0 library/msgs/tr.msg | 0 library/msgs/uk.msg | 0 library/msgs/vi.msg | 0 library/msgs/zh.msg | 0 library/msgs/zh_cn.msg | 0 library/msgs/zh_hk.msg | 0 library/msgs/zh_sg.msg | 0 library/msgs/zh_tw.msg | 0 library/tzdata/Africa/Asmara | 0 library/tzdata/America/Atikokan | 0 library/tzdata/America/Blanc-Sablon | 0 library/tzdata/America/Indiana/Petersburg | 0 library/tzdata/America/Indiana/Tell_City | 0 library/tzdata/America/Indiana/Vincennes | 0 library/tzdata/America/Indiana/Winamac | 0 library/tzdata/America/Moncton | 0 library/tzdata/America/North_Dakota/New_Salem | 0 library/tzdata/America/Resolute | 0 library/tzdata/Atlantic/Faroe | 0 library/tzdata/Australia/Eucla | 0 library/tzdata/Europe/Guernsey | 0 library/tzdata/Europe/Isle_of_Man | 0 library/tzdata/Europe/Jersey | 0 library/tzdata/Europe/Podgorica | 0 library/tzdata/Europe/Volgograd | 0 win/tclWinFile.c | 0 154 files changed, 0 insertions(+), 0 deletions(-) mode change 100644 => 100755 compat/zlib/win32/zlib1.dll mode change 100644 => 100755 compat/zlib/win64/zlib1.dll mode change 100644 => 100755 compat/zlib/zlib2ansi mode change 100755 => 100644 doc/GetCwd.3 mode change 100755 => 100644 doc/GetVersion.3 mode change 100755 => 100644 doc/lset.n mode change 100755 => 100644 generic/tclStrToD.c mode change 100755 => 100644 library/clock.tcl mode change 100755 => 100644 library/encoding/tis-620.enc mode change 100755 => 100644 library/msgs/af.msg mode change 100755 => 100644 library/msgs/af_za.msg mode change 100755 => 100644 library/msgs/ar.msg mode change 100755 => 100644 library/msgs/ar_in.msg mode change 100755 => 100644 library/msgs/ar_jo.msg mode change 100755 => 100644 library/msgs/ar_lb.msg mode change 100755 => 100644 library/msgs/ar_sy.msg mode change 100755 => 100644 library/msgs/be.msg mode change 100755 => 100644 library/msgs/bg.msg mode change 100755 => 100644 library/msgs/bn.msg mode change 100755 => 100644 library/msgs/bn_in.msg mode change 100755 => 100644 library/msgs/ca.msg mode change 100755 => 100644 library/msgs/cs.msg mode change 100755 => 100644 library/msgs/da.msg mode change 100755 => 100644 library/msgs/de.msg mode change 100755 => 100644 library/msgs/de_at.msg mode change 100755 => 100644 library/msgs/de_be.msg mode change 100755 => 100644 library/msgs/el.msg mode change 100755 => 100644 library/msgs/en_au.msg mode change 100755 => 100644 library/msgs/en_be.msg mode change 100755 => 100644 library/msgs/en_bw.msg mode change 100755 => 100644 library/msgs/en_ca.msg mode change 100755 => 100644 library/msgs/en_gb.msg mode change 100755 => 100644 library/msgs/en_hk.msg mode change 100755 => 100644 library/msgs/en_ie.msg mode change 100755 => 100644 library/msgs/en_in.msg mode change 100755 => 100644 library/msgs/en_nz.msg mode change 100755 => 100644 library/msgs/en_ph.msg mode change 100755 => 100644 library/msgs/en_sg.msg mode change 100755 => 100644 library/msgs/en_za.msg mode change 100755 => 100644 library/msgs/en_zw.msg mode change 100755 => 100644 library/msgs/eo.msg mode change 100755 => 100644 library/msgs/es.msg mode change 100755 => 100644 library/msgs/es_ar.msg mode change 100755 => 100644 library/msgs/es_bo.msg mode change 100755 => 100644 library/msgs/es_cl.msg mode change 100755 => 100644 library/msgs/es_co.msg mode change 100755 => 100644 library/msgs/es_cr.msg mode change 100755 => 100644 library/msgs/es_do.msg mode change 100755 => 100644 library/msgs/es_ec.msg mode change 100755 => 100644 library/msgs/es_gt.msg mode change 100755 => 100644 library/msgs/es_hn.msg mode change 100755 => 100644 library/msgs/es_mx.msg mode change 100755 => 100644 library/msgs/es_ni.msg mode change 100755 => 100644 library/msgs/es_pa.msg mode change 100755 => 100644 library/msgs/es_pe.msg mode change 100755 => 100644 library/msgs/es_pr.msg mode change 100755 => 100644 library/msgs/es_py.msg mode change 100755 => 100644 library/msgs/es_sv.msg mode change 100755 => 100644 library/msgs/es_uy.msg mode change 100755 => 100644 library/msgs/es_ve.msg mode change 100755 => 100644 library/msgs/et.msg mode change 100755 => 100644 library/msgs/eu.msg mode change 100755 => 100644 library/msgs/eu_es.msg mode change 100755 => 100644 library/msgs/fa.msg mode change 100755 => 100644 library/msgs/fa_in.msg mode change 100755 => 100644 library/msgs/fa_ir.msg mode change 100755 => 100644 library/msgs/fi.msg mode change 100755 => 100644 library/msgs/fo.msg mode change 100755 => 100644 library/msgs/fo_fo.msg mode change 100755 => 100644 library/msgs/fr.msg mode change 100755 => 100644 library/msgs/fr_be.msg mode change 100755 => 100644 library/msgs/fr_ca.msg mode change 100755 => 100644 library/msgs/fr_ch.msg mode change 100755 => 100644 library/msgs/ga.msg mode change 100755 => 100644 library/msgs/ga_ie.msg mode change 100755 => 100644 library/msgs/gl.msg mode change 100755 => 100644 library/msgs/gl_es.msg mode change 100755 => 100644 library/msgs/gv.msg mode change 100755 => 100644 library/msgs/gv_gb.msg mode change 100755 => 100644 library/msgs/he.msg mode change 100755 => 100644 library/msgs/hi.msg mode change 100755 => 100644 library/msgs/hi_in.msg mode change 100755 => 100644 library/msgs/hr.msg mode change 100755 => 100644 library/msgs/hu.msg mode change 100755 => 100644 library/msgs/id.msg mode change 100755 => 100644 library/msgs/id_id.msg mode change 100755 => 100644 library/msgs/is.msg mode change 100755 => 100644 library/msgs/it.msg mode change 100755 => 100644 library/msgs/it_ch.msg mode change 100755 => 100644 library/msgs/ja.msg mode change 100755 => 100644 library/msgs/kl.msg mode change 100755 => 100644 library/msgs/kl_gl.msg mode change 100755 => 100644 library/msgs/ko.msg mode change 100755 => 100644 library/msgs/ko_kr.msg mode change 100755 => 100644 library/msgs/kok.msg mode change 100755 => 100644 library/msgs/kok_in.msg mode change 100755 => 100644 library/msgs/kw.msg mode change 100755 => 100644 library/msgs/kw_gb.msg mode change 100755 => 100644 library/msgs/lt.msg mode change 100755 => 100644 library/msgs/lv.msg mode change 100755 => 100644 library/msgs/mk.msg mode change 100755 => 100644 library/msgs/mr.msg mode change 100755 => 100644 library/msgs/mr_in.msg mode change 100755 => 100644 library/msgs/ms.msg mode change 100755 => 100644 library/msgs/ms_my.msg mode change 100755 => 100644 library/msgs/mt.msg mode change 100755 => 100644 library/msgs/nb.msg mode change 100755 => 100644 library/msgs/nl.msg mode change 100755 => 100644 library/msgs/nl_be.msg mode change 100755 => 100644 library/msgs/nn.msg mode change 100755 => 100644 library/msgs/pl.msg mode change 100755 => 100644 library/msgs/pt.msg mode change 100755 => 100644 library/msgs/pt_br.msg mode change 100755 => 100644 library/msgs/ro.msg mode change 100755 => 100644 library/msgs/ru.msg mode change 100755 => 100644 library/msgs/ru_ua.msg mode change 100755 => 100644 library/msgs/sh.msg mode change 100755 => 100644 library/msgs/sk.msg mode change 100755 => 100644 library/msgs/sl.msg mode change 100755 => 100644 library/msgs/sq.msg mode change 100755 => 100644 library/msgs/sr.msg mode change 100755 => 100644 library/msgs/sv.msg mode change 100755 => 100644 library/msgs/sw.msg mode change 100755 => 100644 library/msgs/ta.msg mode change 100755 => 100644 library/msgs/ta_in.msg mode change 100755 => 100644 library/msgs/te.msg mode change 100755 => 100644 library/msgs/te_in.msg mode change 100755 => 100644 library/msgs/th.msg mode change 100755 => 100644 library/msgs/tr.msg mode change 100755 => 100644 library/msgs/uk.msg mode change 100755 => 100644 library/msgs/vi.msg mode change 100755 => 100644 library/msgs/zh.msg mode change 100755 => 100644 library/msgs/zh_cn.msg mode change 100755 => 100644 library/msgs/zh_hk.msg mode change 100755 => 100644 library/msgs/zh_sg.msg mode change 100755 => 100644 library/msgs/zh_tw.msg mode change 100755 => 100644 library/tzdata/Africa/Asmara mode change 100755 => 100644 library/tzdata/America/Atikokan mode change 100755 => 100644 library/tzdata/America/Blanc-Sablon mode change 100755 => 100644 library/tzdata/America/Indiana/Petersburg mode change 100755 => 100644 library/tzdata/America/Indiana/Tell_City mode change 100755 => 100644 library/tzdata/America/Indiana/Vincennes mode change 100755 => 100644 library/tzdata/America/Indiana/Winamac mode change 100755 => 100644 library/tzdata/America/Moncton mode change 100755 => 100644 library/tzdata/America/North_Dakota/New_Salem mode change 100755 => 100644 library/tzdata/America/Resolute mode change 100755 => 100644 library/tzdata/Atlantic/Faroe mode change 100755 => 100644 library/tzdata/Australia/Eucla mode change 100755 => 100644 library/tzdata/Europe/Guernsey mode change 100755 => 100644 library/tzdata/Europe/Isle_of_Man mode change 100755 => 100644 library/tzdata/Europe/Jersey mode change 100755 => 100644 library/tzdata/Europe/Podgorica mode change 100755 => 100644 library/tzdata/Europe/Volgograd mode change 100755 => 100644 win/tclWinFile.c diff --git a/compat/zlib/win32/zlib1.dll b/compat/zlib/win32/zlib1.dll old mode 100644 new mode 100755 diff --git a/compat/zlib/win64/zlib1.dll b/compat/zlib/win64/zlib1.dll old mode 100644 new mode 100755 diff --git a/compat/zlib/zlib2ansi b/compat/zlib/zlib2ansi old mode 100644 new mode 100755 diff --git a/doc/GetCwd.3 b/doc/GetCwd.3 old mode 100755 new mode 100644 diff --git a/doc/GetVersion.3 b/doc/GetVersion.3 old mode 100755 new mode 100644 diff --git a/doc/lset.n b/doc/lset.n old mode 100755 new mode 100644 diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c old mode 100755 new mode 100644 diff --git a/library/clock.tcl b/library/clock.tcl old mode 100755 new mode 100644 diff --git a/library/encoding/tis-620.enc b/library/encoding/tis-620.enc old mode 100755 new mode 100644 diff --git a/library/msgs/af.msg b/library/msgs/af.msg old mode 100755 new mode 100644 diff --git a/library/msgs/af_za.msg b/library/msgs/af_za.msg old mode 100755 new mode 100644 diff --git a/library/msgs/ar.msg b/library/msgs/ar.msg old mode 100755 new mode 100644 diff --git a/library/msgs/ar_in.msg b/library/msgs/ar_in.msg old mode 100755 new mode 100644 diff --git a/library/msgs/ar_jo.msg b/library/msgs/ar_jo.msg old mode 100755 new mode 100644 diff --git a/library/msgs/ar_lb.msg b/library/msgs/ar_lb.msg old mode 100755 new mode 100644 diff --git a/library/msgs/ar_sy.msg b/library/msgs/ar_sy.msg old mode 100755 new mode 100644 diff --git a/library/msgs/be.msg b/library/msgs/be.msg old mode 100755 new mode 100644 diff --git a/library/msgs/bg.msg b/library/msgs/bg.msg old mode 100755 new mode 100644 diff --git a/library/msgs/bn.msg b/library/msgs/bn.msg old mode 100755 new mode 100644 diff --git a/library/msgs/bn_in.msg b/library/msgs/bn_in.msg old mode 100755 new mode 100644 diff --git a/library/msgs/ca.msg b/library/msgs/ca.msg old mode 100755 new mode 100644 diff --git a/library/msgs/cs.msg b/library/msgs/cs.msg old mode 100755 new mode 100644 diff --git a/library/msgs/da.msg b/library/msgs/da.msg old mode 100755 new mode 100644 diff --git a/library/msgs/de.msg b/library/msgs/de.msg old mode 100755 new mode 100644 diff --git a/library/msgs/de_at.msg b/library/msgs/de_at.msg old mode 100755 new mode 100644 diff --git a/library/msgs/de_be.msg b/library/msgs/de_be.msg old mode 100755 new mode 100644 diff --git a/library/msgs/el.msg b/library/msgs/el.msg old mode 100755 new mode 100644 diff --git a/library/msgs/en_au.msg b/library/msgs/en_au.msg old mode 100755 new mode 100644 diff --git a/library/msgs/en_be.msg b/library/msgs/en_be.msg old mode 100755 new mode 100644 diff --git a/library/msgs/en_bw.msg b/library/msgs/en_bw.msg old mode 100755 new mode 100644 diff --git a/library/msgs/en_ca.msg b/library/msgs/en_ca.msg old mode 100755 new mode 100644 diff --git a/library/msgs/en_gb.msg b/library/msgs/en_gb.msg old mode 100755 new mode 100644 diff --git a/library/msgs/en_hk.msg b/library/msgs/en_hk.msg old mode 100755 new mode 100644 diff --git a/library/msgs/en_ie.msg b/library/msgs/en_ie.msg old mode 100755 new mode 100644 diff --git a/library/msgs/en_in.msg b/library/msgs/en_in.msg old mode 100755 new mode 100644 diff --git a/library/msgs/en_nz.msg b/library/msgs/en_nz.msg old mode 100755 new mode 100644 diff --git a/library/msgs/en_ph.msg b/library/msgs/en_ph.msg old mode 100755 new mode 100644 diff --git a/library/msgs/en_sg.msg b/library/msgs/en_sg.msg old mode 100755 new mode 100644 diff --git a/library/msgs/en_za.msg b/library/msgs/en_za.msg old mode 100755 new mode 100644 diff --git a/library/msgs/en_zw.msg b/library/msgs/en_zw.msg old mode 100755 new mode 100644 diff --git a/library/msgs/eo.msg b/library/msgs/eo.msg old mode 100755 new mode 100644 diff --git a/library/msgs/es.msg b/library/msgs/es.msg old mode 100755 new mode 100644 diff --git a/library/msgs/es_ar.msg b/library/msgs/es_ar.msg old mode 100755 new mode 100644 diff --git a/library/msgs/es_bo.msg b/library/msgs/es_bo.msg old mode 100755 new mode 100644 diff --git a/library/msgs/es_cl.msg b/library/msgs/es_cl.msg old mode 100755 new mode 100644 diff --git a/library/msgs/es_co.msg b/library/msgs/es_co.msg old mode 100755 new mode 100644 diff --git a/library/msgs/es_cr.msg b/library/msgs/es_cr.msg old mode 100755 new mode 100644 diff --git a/library/msgs/es_do.msg b/library/msgs/es_do.msg old mode 100755 new mode 100644 diff --git a/library/msgs/es_ec.msg b/library/msgs/es_ec.msg old mode 100755 new mode 100644 diff --git a/library/msgs/es_gt.msg b/library/msgs/es_gt.msg old mode 100755 new mode 100644 diff --git a/library/msgs/es_hn.msg b/library/msgs/es_hn.msg old mode 100755 new mode 100644 diff --git a/library/msgs/es_mx.msg b/library/msgs/es_mx.msg old mode 100755 new mode 100644 diff --git a/library/msgs/es_ni.msg b/library/msgs/es_ni.msg old mode 100755 new mode 100644 diff --git a/library/msgs/es_pa.msg b/library/msgs/es_pa.msg old mode 100755 new mode 100644 diff --git a/library/msgs/es_pe.msg b/library/msgs/es_pe.msg old mode 100755 new mode 100644 diff --git a/library/msgs/es_pr.msg b/library/msgs/es_pr.msg old mode 100755 new mode 100644 diff --git a/library/msgs/es_py.msg b/library/msgs/es_py.msg old mode 100755 new mode 100644 diff --git a/library/msgs/es_sv.msg b/library/msgs/es_sv.msg old mode 100755 new mode 100644 diff --git a/library/msgs/es_uy.msg b/library/msgs/es_uy.msg old mode 100755 new mode 100644 diff --git a/library/msgs/es_ve.msg b/library/msgs/es_ve.msg old mode 100755 new mode 100644 diff --git a/library/msgs/et.msg b/library/msgs/et.msg old mode 100755 new mode 100644 diff --git a/library/msgs/eu.msg b/library/msgs/eu.msg old mode 100755 new mode 100644 diff --git a/library/msgs/eu_es.msg b/library/msgs/eu_es.msg old mode 100755 new mode 100644 diff --git a/library/msgs/fa.msg b/library/msgs/fa.msg old mode 100755 new mode 100644 diff --git a/library/msgs/fa_in.msg b/library/msgs/fa_in.msg old mode 100755 new mode 100644 diff --git a/library/msgs/fa_ir.msg b/library/msgs/fa_ir.msg old mode 100755 new mode 100644 diff --git a/library/msgs/fi.msg b/library/msgs/fi.msg old mode 100755 new mode 100644 diff --git a/library/msgs/fo.msg b/library/msgs/fo.msg old mode 100755 new mode 100644 diff --git a/library/msgs/fo_fo.msg b/library/msgs/fo_fo.msg old mode 100755 new mode 100644 diff --git a/library/msgs/fr.msg b/library/msgs/fr.msg old mode 100755 new mode 100644 diff --git a/library/msgs/fr_be.msg b/library/msgs/fr_be.msg old mode 100755 new mode 100644 diff --git a/library/msgs/fr_ca.msg b/library/msgs/fr_ca.msg old mode 100755 new mode 100644 diff --git a/library/msgs/fr_ch.msg b/library/msgs/fr_ch.msg old mode 100755 new mode 100644 diff --git a/library/msgs/ga.msg b/library/msgs/ga.msg old mode 100755 new mode 100644 diff --git a/library/msgs/ga_ie.msg b/library/msgs/ga_ie.msg old mode 100755 new mode 100644 diff --git a/library/msgs/gl.msg b/library/msgs/gl.msg old mode 100755 new mode 100644 diff --git a/library/msgs/gl_es.msg b/library/msgs/gl_es.msg old mode 100755 new mode 100644 diff --git a/library/msgs/gv.msg b/library/msgs/gv.msg old mode 100755 new mode 100644 diff --git a/library/msgs/gv_gb.msg b/library/msgs/gv_gb.msg old mode 100755 new mode 100644 diff --git a/library/msgs/he.msg b/library/msgs/he.msg old mode 100755 new mode 100644 diff --git a/library/msgs/hi.msg b/library/msgs/hi.msg old mode 100755 new mode 100644 diff --git a/library/msgs/hi_in.msg b/library/msgs/hi_in.msg old mode 100755 new mode 100644 diff --git a/library/msgs/hr.msg b/library/msgs/hr.msg old mode 100755 new mode 100644 diff --git a/library/msgs/hu.msg b/library/msgs/hu.msg old mode 100755 new mode 100644 diff --git a/library/msgs/id.msg b/library/msgs/id.msg old mode 100755 new mode 100644 diff --git a/library/msgs/id_id.msg b/library/msgs/id_id.msg old mode 100755 new mode 100644 diff --git a/library/msgs/is.msg b/library/msgs/is.msg old mode 100755 new mode 100644 diff --git a/library/msgs/it.msg b/library/msgs/it.msg old mode 100755 new mode 100644 diff --git a/library/msgs/it_ch.msg b/library/msgs/it_ch.msg old mode 100755 new mode 100644 diff --git a/library/msgs/ja.msg b/library/msgs/ja.msg old mode 100755 new mode 100644 diff --git a/library/msgs/kl.msg b/library/msgs/kl.msg old mode 100755 new mode 100644 diff --git a/library/msgs/kl_gl.msg b/library/msgs/kl_gl.msg old mode 100755 new mode 100644 diff --git a/library/msgs/ko.msg b/library/msgs/ko.msg old mode 100755 new mode 100644 diff --git a/library/msgs/ko_kr.msg b/library/msgs/ko_kr.msg old mode 100755 new mode 100644 diff --git a/library/msgs/kok.msg b/library/msgs/kok.msg old mode 100755 new mode 100644 diff --git a/library/msgs/kok_in.msg b/library/msgs/kok_in.msg old mode 100755 new mode 100644 diff --git a/library/msgs/kw.msg b/library/msgs/kw.msg old mode 100755 new mode 100644 diff --git a/library/msgs/kw_gb.msg b/library/msgs/kw_gb.msg old mode 100755 new mode 100644 diff --git a/library/msgs/lt.msg b/library/msgs/lt.msg old mode 100755 new mode 100644 diff --git a/library/msgs/lv.msg b/library/msgs/lv.msg old mode 100755 new mode 100644 diff --git a/library/msgs/mk.msg b/library/msgs/mk.msg old mode 100755 new mode 100644 diff --git a/library/msgs/mr.msg b/library/msgs/mr.msg old mode 100755 new mode 100644 diff --git a/library/msgs/mr_in.msg b/library/msgs/mr_in.msg old mode 100755 new mode 100644 diff --git a/library/msgs/ms.msg b/library/msgs/ms.msg old mode 100755 new mode 100644 diff --git a/library/msgs/ms_my.msg b/library/msgs/ms_my.msg old mode 100755 new mode 100644 diff --git a/library/msgs/mt.msg b/library/msgs/mt.msg old mode 100755 new mode 100644 diff --git a/library/msgs/nb.msg b/library/msgs/nb.msg old mode 100755 new mode 100644 diff --git a/library/msgs/nl.msg b/library/msgs/nl.msg old mode 100755 new mode 100644 diff --git a/library/msgs/nl_be.msg b/library/msgs/nl_be.msg old mode 100755 new mode 100644 diff --git a/library/msgs/nn.msg b/library/msgs/nn.msg old mode 100755 new mode 100644 diff --git a/library/msgs/pl.msg b/library/msgs/pl.msg old mode 100755 new mode 100644 diff --git a/library/msgs/pt.msg b/library/msgs/pt.msg old mode 100755 new mode 100644 diff --git a/library/msgs/pt_br.msg b/library/msgs/pt_br.msg old mode 100755 new mode 100644 diff --git a/library/msgs/ro.msg b/library/msgs/ro.msg old mode 100755 new mode 100644 diff --git a/library/msgs/ru.msg b/library/msgs/ru.msg old mode 100755 new mode 100644 diff --git a/library/msgs/ru_ua.msg b/library/msgs/ru_ua.msg old mode 100755 new mode 100644 diff --git a/library/msgs/sh.msg b/library/msgs/sh.msg old mode 100755 new mode 100644 diff --git a/library/msgs/sk.msg b/library/msgs/sk.msg old mode 100755 new mode 100644 diff --git a/library/msgs/sl.msg b/library/msgs/sl.msg old mode 100755 new mode 100644 diff --git a/library/msgs/sq.msg b/library/msgs/sq.msg old mode 100755 new mode 100644 diff --git a/library/msgs/sr.msg b/library/msgs/sr.msg old mode 100755 new mode 100644 diff --git a/library/msgs/sv.msg b/library/msgs/sv.msg old mode 100755 new mode 100644 diff --git a/library/msgs/sw.msg b/library/msgs/sw.msg old mode 100755 new mode 100644 diff --git a/library/msgs/ta.msg b/library/msgs/ta.msg old mode 100755 new mode 100644 diff --git a/library/msgs/ta_in.msg b/library/msgs/ta_in.msg old mode 100755 new mode 100644 diff --git a/library/msgs/te.msg b/library/msgs/te.msg old mode 100755 new mode 100644 diff --git a/library/msgs/te_in.msg b/library/msgs/te_in.msg old mode 100755 new mode 100644 diff --git a/library/msgs/th.msg b/library/msgs/th.msg old mode 100755 new mode 100644 diff --git a/library/msgs/tr.msg b/library/msgs/tr.msg old mode 100755 new mode 100644 diff --git a/library/msgs/uk.msg b/library/msgs/uk.msg old mode 100755 new mode 100644 diff --git a/library/msgs/vi.msg b/library/msgs/vi.msg old mode 100755 new mode 100644 diff --git a/library/msgs/zh.msg b/library/msgs/zh.msg old mode 100755 new mode 100644 diff --git a/library/msgs/zh_cn.msg b/library/msgs/zh_cn.msg old mode 100755 new mode 100644 diff --git a/library/msgs/zh_hk.msg b/library/msgs/zh_hk.msg old mode 100755 new mode 100644 diff --git a/library/msgs/zh_sg.msg b/library/msgs/zh_sg.msg old mode 100755 new mode 100644 diff --git a/library/msgs/zh_tw.msg b/library/msgs/zh_tw.msg old mode 100755 new mode 100644 diff --git a/library/tzdata/Africa/Asmara b/library/tzdata/Africa/Asmara old mode 100755 new mode 100644 diff --git a/library/tzdata/America/Atikokan b/library/tzdata/America/Atikokan old mode 100755 new mode 100644 diff --git a/library/tzdata/America/Blanc-Sablon b/library/tzdata/America/Blanc-Sablon old mode 100755 new mode 100644 diff --git a/library/tzdata/America/Indiana/Petersburg b/library/tzdata/America/Indiana/Petersburg old mode 100755 new mode 100644 diff --git a/library/tzdata/America/Indiana/Tell_City b/library/tzdata/America/Indiana/Tell_City old mode 100755 new mode 100644 diff --git a/library/tzdata/America/Indiana/Vincennes b/library/tzdata/America/Indiana/Vincennes old mode 100755 new mode 100644 diff --git a/library/tzdata/America/Indiana/Winamac b/library/tzdata/America/Indiana/Winamac old mode 100755 new mode 100644 diff --git a/library/tzdata/America/Moncton b/library/tzdata/America/Moncton old mode 100755 new mode 100644 diff --git a/library/tzdata/America/North_Dakota/New_Salem b/library/tzdata/America/North_Dakota/New_Salem old mode 100755 new mode 100644 diff --git a/library/tzdata/America/Resolute b/library/tzdata/America/Resolute old mode 100755 new mode 100644 diff --git a/library/tzdata/Atlantic/Faroe b/library/tzdata/Atlantic/Faroe old mode 100755 new mode 100644 diff --git a/library/tzdata/Australia/Eucla b/library/tzdata/Australia/Eucla old mode 100755 new mode 100644 diff --git a/library/tzdata/Europe/Guernsey b/library/tzdata/Europe/Guernsey old mode 100755 new mode 100644 diff --git a/library/tzdata/Europe/Isle_of_Man b/library/tzdata/Europe/Isle_of_Man old mode 100755 new mode 100644 diff --git a/library/tzdata/Europe/Jersey b/library/tzdata/Europe/Jersey old mode 100755 new mode 100644 diff --git a/library/tzdata/Europe/Podgorica b/library/tzdata/Europe/Podgorica old mode 100755 new mode 100644 diff --git a/library/tzdata/Europe/Volgograd b/library/tzdata/Europe/Volgograd old mode 100755 new mode 100644 diff --git a/win/tclWinFile.c b/win/tclWinFile.c old mode 100755 new mode 100644 -- cgit v0.12 From c5bbe85f29a60e507f1510d6de30b07be24c9f64 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 7 Nov 2018 13:25:45 +0000 Subject: Rebase of travis config --- .travis.yml | 91 +++++++++++++++++++++++++++++ README | 185 ---------------------------------------------------------- tests/all.tcl | 4 +- 3 files changed, 94 insertions(+), 186 deletions(-) diff --git a/.travis.yml b/.travis.yml index 64801ec..7cf6989 100644 --- a/.travis.yml +++ b/.travis.yml @@ -6,6 +6,97 @@ matrix: - os: linux compiler: clang env: + - MATRIX_EVAL="" BUILD_DIR=unix + - os: linux + compiler: clang + env: + - MATRIX_EVAL="" BUILD_DIR=unix CFGOPT=--disable-shared + - os: linux + compiler: gcc + env: + - MATRIX_EVAL="" BUILD_DIR=unix + - os: linux + compiler: gcc + env: + - MATRIX_EVAL="" BUILD_DIR=unix CFGOPT=--disable-shared + - os: linux + compiler: gcc + addons: + apt: + sources: + - ubuntu-toolchain-r-test + packages: + - g++-4.9 + env: + - MATRIX_EVAL="CC=gcc-4.9" BUILD_DIR=unix + - os: linux + compiler: gcc + addons: + apt: + sources: + - ubuntu-toolchain-r-test + packages: + - g++-5 + env: + - MATRIX_EVAL="CC=gcc-5" BUILD_DIR=unix + - os: linux + compiler: gcc + addons: + apt: + sources: + - ubuntu-toolchain-r-test + packages: + - g++-6 + env: + - MATRIX_EVAL="CC=gcc-6" BUILD_DIR=unix + - os: linux + compiler: gcc + addons: + apt: + sources: + - ubuntu-toolchain-r-test + packages: + - g++-7 + env: + - MATRIX_EVAL="CC=gcc-7" BUILD_DIR=unix + - os: osx + osx_image: xcode8 + env: + - MATRIX_EVAL="" BUILD_DIR=unix + - os: osx + osx_image: xcode8 + env: + - MATRIX_EVAL="" BUILD_DIR=macosx NO_DIRECT_CONFIGURE=1 + - os: osx + osx_image: xcode9 + env: + - MATRIX_EVAL="" BUILD_DIR=macosx NO_DIRECT_CONFIGURE=1 + - os: osx + osx_image: xcode10 + env: + - MATRIX_EVAL="" BUILD_DIR=macosx NO_DIRECT_CONFIGURE=1 +### C builds not currently supported on Windows instances +# - os: windows +# env: +# - MATRIX_EVAL="" BUILD_DIR=win + +before_install: + - eval "${MATRIX_EVAL}" + - export ERROR_ON_FAILURES=1 + - cd ${BUILD_DIR} +install: + - test -n "$NO_DIRECT_CONFIGURE" || ./configure ${CFGOPT} +script: + - make + - make test +dist: trusty +sudo: false +language: c +matrix: + include: + - os: linux + compiler: clang + env: - MATRIX_EVAL="" - BUILD_DIR=unix - os: linux diff --git a/README b/README index adfdf97..e69de29 100644 --- a/README +++ b/README @@ -1,185 +0,0 @@ -README: Tcl - This is the Tcl 8.6.8 source distribution. - http://sourceforge.net/projects/tcl/files/Tcl/ - You can get any source release of Tcl from the URL above. - -Contents --------- - 1. Introduction - 2. Documentation - 3. Compiling and installing Tcl - 4. Development tools - 5. Tcl newsgroup - 6. The Tcler's Wiki - 7. Mailing lists - 8. Support and Training - 9. Tracking Development - 10. Thank You - -1. Introduction ---------------- -Tcl provides a powerful platform for creating integration applications that -tie together diverse applications, protocols, devices, and frameworks. -When paired with the Tk toolkit, Tcl provides the fastest and most powerful -way to create GUI applications that run on PCs, Unix, and Mac OS X. -Tcl can also be used for a variety of web-related tasks and for creating -powerful command languages for applications. - -Tcl is maintained, enhanced, and distributed freely by the Tcl community. -Source code development and tracking of bug reports and feature requests -takes place at: - - http://core.tcl.tk/ - -Tcl/Tk release and mailing list services are hosted by SourceForge: - - http://sourceforge.net/projects/tcl/ - -with the Tcl Developer Xchange hosted at: - - http://www.tcl.tk/ - -Tcl is a freely available open source package. You can do virtually -anything you like with it, such as modifying it, redistributing it, -and selling it either in whole or in part. See the file -"license.terms" for complete information. - -2. Documentation ----------------- - -Extensive documentation is available at our website. -The home page for this release, including new features, is - http://www.tcl.tk/software/tcltk/8.6.html - -Detailed release notes can be found at the file distributions page -by clicking on the relevant version. - http://sourceforge.net/projects/tcl/files/Tcl/ - -Information about Tcl itself can be found at - http://www.tcl.tk/about/ - -There have been many Tcl books on the market. Many are mentioned in the Wiki: - http://wiki.tcl.tk/_/ref?N=25206 - -To view the complete set of reference manual entries for Tcl 8.6 online, -visit the URL: - http://www.tcl.tk/man/tcl8.6/ - -2a. Unix Documentation ----------------------- - -The "doc" subdirectory in this release contains a complete set of -reference manual entries for Tcl. Files with extension ".1" are for -programs (for example, tclsh.1); files with extension ".3" are for C -library procedures; and files with extension ".n" describe Tcl -commands. The file "doc/Tcl.n" gives a quick summary of the Tcl -language syntax. To print any of the man pages on Unix, cd to the -"doc" directory and invoke your favorite variant of troff using the -normal -man macros, for example - - ditroff -man Tcl.n - -to print Tcl.n. If Tcl has been installed correctly and your "man" program -supports it, you should be able to access the Tcl manual entries using the -normal "man" mechanisms, such as - - man Tcl - -2b. Windows Documentation -------------------------- - -The "doc" subdirectory in this release contains a complete set of Windows -help files for Tcl. Once you install this Tcl release, a shortcut to the -Windows help Tcl documentation will appear in the "Start" menu: - - Start | Programs | Tcl | Tcl Help - -3. Compiling and installing Tcl -------------------------------- - -There are brief notes in the unix/README, win/README, and macosx/README about -compiling on these different platforms. There is additional information -about building Tcl from sources at - - http://www.tcl.tk/doc/howto/compile.html - -4. Development tools ---------------------------- - -ActiveState produces a high quality set of commercial quality development -tools that is available to accelerate your Tcl application development. -Tcl Dev Kit builds on the earlier TclPro toolset and provides a debugger, -static code checker, single-file wrapping utility, bytecode compiler and -more. More information can be found at - - http://www.ActiveState.com/Tcl - -5. Tcl newsgroup ----------------- - -There is a USENET news group, "comp.lang.tcl", intended for the exchange of -information about Tcl, Tk, and related applications. The newsgroup is a -great place to ask general information questions. For bug reports, please -see the "Support and bug fixes" section below. - -6. Tcl'ers Wiki ---------------- - -A Wiki-based open community site covering all aspects of Tcl/Tk is at: - - http://wiki.tcl.tk/ - -It is dedicated to the Tcl programming language and its extensions. A -wealth of useful information can be found there. It contains code -snippets, references to papers, books, and FAQs, as well as pointers to -development tools, extensions, and applications. You can also recommend -additional URLs by editing the wiki yourself. - -7. Mailing lists ----------------- - -Several mailing lists are hosted at SourceForge to discuss development or -use issues (like Macintosh and Windows topics). For more information and -to subscribe, visit: - - http://sourceforge.net/projects/tcl/ - -and go to the Mailing Lists page. - -8. Support and Training ------------------------- - -We are very interested in receiving bug reports, patches, and suggestions -for improvements. We prefer that you send this information to us as -tickets entered into our tracker at: - - http://core.tcl.tk/tcl/reportlist - -We will log and follow-up on each bug, although we cannot promise a -specific turn-around time. Enhancements may take longer and may not happen -at all unless there is widespread support for them (we're trying to -slow the rate at which Tcl/Tk turns into a kitchen sink). It's very -difficult to make incompatible changes to Tcl/Tk at this point, due to -the size of the installed base. - -The Tcl community is too large for us to provide much individual support -for users. If you need help we suggest that you post questions to -comp.lang.tcl. We read the newsgroup and will attempt to answer esoteric -questions for which no one else is likely to know the answer. In addition, -see the following Web site for links to other organizations that offer -Tcl/Tk training: - - http://wiki.tcl.tk/training - -9. Tracking Development ------------------------ - -Tcl is developed in public. To keep an eye on how Tcl is changing, see - http://core.tcl.tk/ - -10. Thank You -------------- - -We'd like to express our thanks to the Tcl community for all the -helpful suggestions, bug reports, and patches we have received. -Tcl/Tk has improved vastly and will continue to do so with your help. diff --git a/tests/all.tcl b/tests/all.tcl index e14bd9c..89a4f1a 100644 --- a/tests/all.tcl +++ b/tests/all.tcl @@ -22,5 +22,7 @@ if {[singleProcess]} { interp debug {} -frame 1 } -runAllTests +set ErrorOnFailures [info exists env(ERROR_ON_FAILURES)] +unset -nocomplain env(ERROR_ON_FAILURES) +if {[runAllTests] && $ErrorOnFailures} {exit 1} proc exit args {} -- cgit v0.12 From c1c94e44379f02e1007a4351ce6c40b17a352b4a Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 7 Nov 2018 18:50:09 +0000 Subject: [86d249bcba] Make sure that tcltest::runAllTests actually returns 1 on failure --- library/tcltest/tcltest.tcl | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index 410aa24..d67a900 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -2752,6 +2752,7 @@ proc tcltest::runAllTests { {shell ""} } { variable numTests variable failFiles variable DefaultValue + set failFilesAccum {} FillFilesExisted if {[llength [info level 0]] == 1} { @@ -2841,6 +2842,7 @@ proc tcltest::runAllTests { {shell ""} } { } if {$Failed > 0} { lappend failFiles $testFile + lappend failFilesAccum $testFile } } elseif {[regexp [join { {^Number of tests skipped } @@ -2887,7 +2889,7 @@ proc tcltest::runAllTests { {shell ""} } { puts [outputChannel] "" puts [outputChannel] [string repeat ~ 44] } - return [info exists testFileFailures] + return [expr {[info exists testFileFailures] || [llength $failFilesAccum]}] } ##################################################################### -- cgit v0.12 From 155f409a383ca0411146efb82246e52ec12270fe Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 7 Nov 2018 19:22:20 +0000 Subject: Merge the Travis build rules more properly --- .travis.yml | 160 ++++++++++-------------------------------------------------- 1 file changed, 27 insertions(+), 133 deletions(-) diff --git a/.travis.yml b/.travis.yml index 7cf6989..230885d 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,25 +1,30 @@ -dist: trusty sudo: false language: c + matrix: include: - os: linux + dist: trusty compiler: clang env: - - MATRIX_EVAL="" BUILD_DIR=unix + - CFGOPT=--enable-shared BUILD_DIR=unix MATRIX_EVAL="" - os: linux + dist: trusty compiler: clang env: - - MATRIX_EVAL="" BUILD_DIR=unix CFGOPT=--disable-shared + - CFGOPT=--disable-shared BUILD_DIR=unix MATRIX_EVAL="" - os: linux + dist: trusty compiler: gcc env: - - MATRIX_EVAL="" BUILD_DIR=unix + - CFGOPT=--enable-shared BUILD_DIR=unix MATRIX_EVAL="" - os: linux + dist: trusty compiler: gcc env: - - MATRIX_EVAL="" BUILD_DIR=unix CFGOPT=--disable-shared + - CFGOPT=--disable-shared BUILD_DIR=unix MATRIX_EVAL="" - os: linux + dist: trusty compiler: gcc addons: apt: @@ -28,8 +33,9 @@ matrix: packages: - g++-4.9 env: - - MATRIX_EVAL="CC=gcc-4.9" BUILD_DIR=unix + - CC=gcc-4.9 BUILD_DIR=unix MATRIX_EVAL="CC=gcc-4.9" - os: linux + dist: trusty compiler: gcc addons: apt: @@ -38,8 +44,9 @@ matrix: packages: - g++-5 env: - - MATRIX_EVAL="CC=gcc-5" BUILD_DIR=unix + - CC=gcc-5 BUILD_DIR=unix MATRIX_EVAL="CC=gcc-5" - os: linux + dist: trusty compiler: gcc addons: apt: @@ -48,8 +55,9 @@ matrix: packages: - g++-6 env: - - MATRIX_EVAL="CC=gcc-6" BUILD_DIR=unix + - CC=gcc-6 BUILD_DIR=unix MATRIX_EVAL="CC=gcc-6" - os: linux + dist: trusty compiler: gcc addons: apt: @@ -58,133 +66,31 @@ matrix: packages: - g++-7 env: - - MATRIX_EVAL="CC=gcc-7" BUILD_DIR=unix + - CC=gcc-7 BUILD_DIR=unix MATRIX_EVAL="CC=gcc-7" - os: osx osx_image: xcode8 env: - - MATRIX_EVAL="" BUILD_DIR=unix + - BUILD_DIR=unix MATRIX_EVAL="" - os: osx osx_image: xcode8 env: - - MATRIX_EVAL="" BUILD_DIR=macosx NO_DIRECT_CONFIGURE=1 + - BUILD_DIR=macosx MATRIX_EVAL="" NO_DIRECT_CONFIGURE=1 - os: osx osx_image: xcode9 env: - - MATRIX_EVAL="" BUILD_DIR=macosx NO_DIRECT_CONFIGURE=1 + - BUILD_DIR=macosx MATRIX_EVAL="" NO_DIRECT_CONFIGURE=1 - os: osx osx_image: xcode10 env: - - MATRIX_EVAL="" BUILD_DIR=macosx NO_DIRECT_CONFIGURE=1 + - BUILD_DIR=macosx MATRIX_EVAL="" NO_DIRECT_CONFIGURE=1 ### C builds not currently supported on Windows instances # - os: windows # env: -# - MATRIX_EVAL="" BUILD_DIR=win - -before_install: - - eval "${MATRIX_EVAL}" - - export ERROR_ON_FAILURES=1 - - cd ${BUILD_DIR} -install: - - test -n "$NO_DIRECT_CONFIGURE" || ./configure ${CFGOPT} -script: - - make - - make test -dist: trusty -sudo: false -language: c -matrix: - include: - - os: linux - compiler: clang - env: - - MATRIX_EVAL="" - - BUILD_DIR=unix - - os: linux - compiler: clang - env: - - MATRIX_EVAL="" - - BUILD_DIR=unix - - CFGOPT=--disable-shared - - os: linux - compiler: gcc - env: - - MATRIX_EVAL="" - - BUILD_DIR=unix - - os: linux - compiler: gcc - env: - - MATRIX_EVAL="" - - BUILD_DIR=unix - - CFGOPT=--disable-shared - - os: linux - compiler: gcc - addons: - apt: - sources: - - ubuntu-toolchain-r-test - packages: - - g++-4.9 - env: - - MATRIX_EVAL="CC=gcc-4.9" - - BUILD_DIR=unix - - os: linux - compiler: gcc - addons: - apt: - sources: - - ubuntu-toolchain-r-test - packages: - - g++-5 - env: - - MATRIX_EVAL="CC=gcc-5" - - BUILD_DIR=unix - - os: linux - compiler: gcc - addons: - apt: - sources: - - ubuntu-toolchain-r-test - packages: - - g++-6 - env: - - MATRIX_EVAL="CC=gcc-6" - - BUILD_DIR=unix - - os: linux - compiler: gcc - addons: - apt: - sources: - - ubuntu-toolchain-r-test - packages: - - g++-7 - env: - - MATRIX_EVAL="CC=gcc-7" - - BUILD_DIR=unix - - os: osx - osx_image: xcode8 - env: - - MATRIX_EVAL="" - - BUILD_DIR=unix - - os: osx - osx_image: xcode8 - env: - - MATRIX_EVAL="" - - BUILD_DIR=macosx - - NO_DIRECT_CONFIGURE=1 - - os: osx - osx_image: xcode9 - env: - - MATRIX_EVAL="" - - BUILD_DIR=macosx - - NO_DIRECT_CONFIGURE=1 - - os: osx - osx_image: xcode10 - env: - - MATRIX_EVAL="" - - BUILD_DIR=macosx - - NO_DIRECT_CONFIGURE=1 +# - BUILD_DIR=win MATRIX_EVAL="" +### ... so proxy with a Mingw cross-compile # Test with mingw-w64 (32 bit) - os: linux + dist: trusty compiler: i686-w64-mingw32-gcc addons: apt: @@ -196,13 +102,10 @@ matrix: - gcc-multilib - wine env: - - MATRIX_EVAL="" - - BUILD_DIR=win - - CFGOPT=--host=i686-w64-mingw32 - - NO_DIRECT_TEST=1 - + - BUILD_DIR=win MATRIX_EVAL="" CFGOPT=--host=i686-w64-mingw32 NO_DIRECT_TEST=1 # Test with mingw-w64 (64 bit) - os: linux + dist: trusty compiler: x86_64-w64-mingw32-gcc addons: apt: @@ -213,16 +116,7 @@ matrix: - gcc-mingw-w64 - wine env: - - MATRIX_EVAL="" - - BUILD_DIR=win - - CFGOPT=--host=x86_64-w64-mingw32 --enable-64bit - - NO_DIRECT_TEST=1 - -### C builds not currently supported on Windows instances -# - os: windows -# env: -# - MATRIX_EVAL="" -# - BUILD_DIR=win + - BUILD_DIR=win MATRIX_EVAL="" CFGOPT="--host=x86_64-w64-mingw32 --enable-64bit" NO_DIRECT_TEST=1 before_install: - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then rvm get stable; fi -- cgit v0.12 From 7d16c9044ecbe5c1191d68fe64dbf84380a9f59c Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 8 Nov 2018 10:40:31 +0000 Subject: TESTBUGFIX: The C locale is more commonly based on UTF-8 than it used to be. --- tests/unixInit.test | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/tests/unixInit.test b/tests/unixInit.test index 0469ee8..74307dd 100644 --- a/tests/unixInit.test +++ b/tests/unixInit.test @@ -341,8 +341,7 @@ test unixInit-3.1 {TclpSetInitialEncodings} -constraints { return $enc } -cleanup { unset -nocomplain env(LANG) -} -match regexp -result [expr { - ($tcl_platform(os) eq "Darwin") ? "^utf-8$" : "^iso8859-15?$"}] +} -match regexp -result {^(iso8859-15?|utf-8)$} test unixInit-3.2 {TclpSetInitialEncodings} -setup { catch {set oldlc_all $env(LC_ALL)} } -constraints {unix stdio} -body { -- cgit v0.12 From 54713545714ae9ba3d1815ce5dc99ec4b6386e0b Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 8 Nov 2018 17:05:00 +0000 Subject: [86d249bcba] Make sure that tcltest::runAllTests actually returns 1 on failure. Repairs TIP 525 Implementation. --- library/tcltest/tcltest.tcl | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index 410aa24..d67a900 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -2752,6 +2752,7 @@ proc tcltest::runAllTests { {shell ""} } { variable numTests variable failFiles variable DefaultValue + set failFilesAccum {} FillFilesExisted if {[llength [info level 0]] == 1} { @@ -2841,6 +2842,7 @@ proc tcltest::runAllTests { {shell ""} } { } if {$Failed > 0} { lappend failFiles $testFile + lappend failFilesAccum $testFile } } elseif {[regexp [join { {^Number of tests skipped } @@ -2887,7 +2889,7 @@ proc tcltest::runAllTests { {shell ""} } { puts [outputChannel] "" puts [outputChannel] [string repeat ~ 44] } - return [info exists testFileFailures] + return [expr {[info exists testFileFailures] || [llength $failFilesAccum]}] } ##################################################################### -- cgit v0.12 From dc53840e353c04b7ec46e42347759fa9ca682258 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 8 Nov 2018 17:06:02 +0000 Subject: [86d249bcba] Make sure that tcltest::runAllTests actually returns 1 on failure Repairs TIP 525 implementation. --- library/tcltest/tcltest.tcl | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index 410aa24..d67a900 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -2752,6 +2752,7 @@ proc tcltest::runAllTests { {shell ""} } { variable numTests variable failFiles variable DefaultValue + set failFilesAccum {} FillFilesExisted if {[llength [info level 0]] == 1} { @@ -2841,6 +2842,7 @@ proc tcltest::runAllTests { {shell ""} } { } if {$Failed > 0} { lappend failFiles $testFile + lappend failFilesAccum $testFile } } elseif {[regexp [join { {^Number of tests skipped } @@ -2887,7 +2889,7 @@ proc tcltest::runAllTests { {shell ""} } { puts [outputChannel] "" puts [outputChannel] [string repeat ~ 44] } - return [info exists testFileFailures] + return [expr {[info exists testFileFailures] || [llength $failFilesAccum]}] } ##################################################################### -- cgit v0.12 From 13446e004af0e7e4579070f7a39b9b48b7500185 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 8 Nov 2018 17:32:28 +0000 Subject: typo --- changes | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/changes b/changes index 7800289..f201ac0 100644 --- a/changes +++ b/changes @@ -8884,7 +8884,7 @@ improvements to regexp engine from Postgres (lane,porter,fellows,seltenreich) 2018-10-26 (enhance) advance dde version (nijtmans) => dde 1.4.1 -2018-10-27 tzdata updated to Olson's tzdata2017g (jima) +2018-10-27 tzdata updated to Olson's tzdata2018g (jima) 2018-10-29 Update tcltest package for Travis support (fellows) => tcltest 2.5.0 -- cgit v0.12 From 75399e97a85433a3805da49a5a11350610a369ae Mon Sep 17 00:00:00 2001 From: sebres Date: Fri, 9 Nov 2018 14:13:15 +0000 Subject: test case to cover bug [35a8f1c04a] --- tests/list.test | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/tests/list.test b/tests/list.test index 5a002a9..56414f7 100644 --- a/tests/list.test +++ b/tests/list.test @@ -108,6 +108,21 @@ test list-3.1 {SetListFromAny and lrange/concat results} { test list-4.1 {Bug 3173086} { string is list "{[list \\\\\}]}" } 1 +test list-4.2 {Bug 35a8f1c04a, check correct str-rep} { + set result {} + foreach i { + {#"} {#"""} {#"""""""""""""""} + "#\"{" "#\"\"\"{" "#\"\"\"\"\"\"\"\"\"\"\"\"\"\"\"\{" + "#\"}" "#\"\"\"}" "#\"\"\"\"\"\"\"\"\"\"\"\"\"\"\"\}" + } { + set list [list $i] + set list [string trim " $list "] + if {[llength $list] > 1 || $i ne [lindex $list 0]} { + lappend result "wrong string-representation of list by '$i', length: [llength $list], list: '$list'" + } + } + set result [join $result \n] +} {} # cleanup ::tcltest::cleanupTests -- cgit v0.12 From ddae61a859c90b865bf0d82684638b80522d7922 Mon Sep 17 00:00:00 2001 From: sebres Date: Fri, 9 Nov 2018 14:19:08 +0000 Subject: closes [35a8f1c04a]: minimalist fix - beware of discrepancy between TclScanElement and TclConvertElement (prefer braces considering TCL_DONT_QUOTE_HASH in case of first list element) --- generic/tclUtil.c | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/generic/tclUtil.c b/generic/tclUtil.c index fb5b21c..2a0d51a 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -944,6 +944,10 @@ TclScanElement( int preferEscape = 0; /* Use preferences to track whether to use */ int preferBrace = 0; /* CONVERT_MASK mode. */ int braceCount = 0; /* Count of all braces '{' '}' seen. */ + + if ((*src == '#') && !(*flagPtr & TCL_DONT_QUOTE_HASH)) { + preferBrace = 1; + } #endif if ((p == NULL) || (length == 0) || ((*p == '\0') && (length == -1))) { -- cgit v0.12 From 83ec300abdbc8486b4fd3272cd74a9c3f162ad7f Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 9 Nov 2018 15:39:26 +0000 Subject: Revise bug fix to support (length == 0) correctly. Added comments and improved safety in caller. --- generic/tclListObj.c | 19 ++++++++++++++++++- generic/tclUtil.c | 21 +++++++++++++++++---- 2 files changed, 35 insertions(+), 5 deletions(-) diff --git a/generic/tclListObj.c b/generic/tclListObj.c index e1dba8c..09ad034 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -1872,7 +1872,21 @@ UpdateStringOfList( * Pass 2: copy into string rep buffer. */ + /* + * We used to set the string length here, relying on a presumed + * guarantee that the number of bytes TclScanElement() calls reported + * to be needed was a precise count and not an over-estimate, so long + * as the same flag values were passed to TclConvertElement(). + * + * Then we saw [35a8f1c04a], where a bug in TclScanElement() caused + * that guarantee to fail. Rather than trust there are no more bugs, + * we set the length after the loop based on what was actually written, + * an not on what was predicted. + * listPtr->length = bytesNeeded - 1; + * + */ + listPtr->bytes = ckalloc((unsigned) bytesNeeded); dst = listPtr->bytes; for (i = 0; i < numElems; i++) { @@ -1881,7 +1895,10 @@ UpdateStringOfList( dst += TclConvertElement(elem, length, dst, flagPtr[i]); *dst++ = ' '; } - listPtr->bytes[listPtr->length] = '\0'; + dst[-1] = '\0'; + + /* Here is the safe setting of the string length. */ + listPtr->length = dst - 1 - listPtr->bytes; if (flagPtr != localFlags) { ckfree((char *) flagPtr); diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 2a0d51a..d065069 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -944,10 +944,6 @@ TclScanElement( int preferEscape = 0; /* Use preferences to track whether to use */ int preferBrace = 0; /* CONVERT_MASK mode. */ int braceCount = 0; /* Count of all braces '{' '}' seen. */ - - if ((*src == '#') && !(*flagPtr & TCL_DONT_QUOTE_HASH)) { - preferBrace = 1; - } #endif if ((p == NULL) || (length == 0) || ((*p == '\0') && (length == -1))) { @@ -956,6 +952,23 @@ TclScanElement( return 2; } +#if COMPAT + /* + * We have an established history in TclConvertElement() when quoting + * because of a leading hash character to force what would be the + * CONVERT_MASK mode into the CONVERT_BRACE mode. That is, we format + * the element #{a"b} like this: + * {#{a"b}} + * and not like this: + * \#{a\"b} + * This is inconsistent with [list x{a"b}], but we will not change that now. + * Set that preference here so that we compute a tight size requirement. + */ + if ((*src == '#') && !(*flagPtr & TCL_DONT_QUOTE_HASH)) { + preferBrace = 1; + } +#endif + if ((*p == '{') || (*p == '"')) { /* * Must escape or protect so leading character of value is not -- cgit v0.12 From 4df4dafad67c2feba67b0d628d7174937e6c2742 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 9 Nov 2018 15:47:37 +0000 Subject: Additional test --- tests/list.test | 3 +++ 1 file changed, 3 insertions(+) diff --git a/tests/list.test b/tests/list.test index 56414f7..18cc42a 100644 --- a/tests/list.test +++ b/tests/list.test @@ -123,6 +123,9 @@ test list-4.2 {Bug 35a8f1c04a, check correct str-rep} { } set result [join $result \n] } {} +test list-4.3 {Bug 35a8f1c04a, check correct string length} { + string length [list #""] +} 5 # cleanup ::tcltest::cleanupTests -- cgit v0.12 From d16fc1a584edbda22d31fb06b50f3fe78439cdf2 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 9 Nov 2018 16:42:37 +0000 Subject: [35a8f1c04a] Fix bad lengths when creating string rep of some lists. --- generic/tclListObj.c | 19 ++++++++++++++++++- generic/tclUtil.c | 17 +++++++++++++++++ tests/list.test | 18 ++++++++++++++++++ 3 files changed, 53 insertions(+), 1 deletion(-) diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 786e1ce..e42567e 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -1990,7 +1990,21 @@ UpdateStringOfList( * Pass 2: copy into string rep buffer. */ + /* + * We used to set the string length here, relying on a presumed + * guarantee that the number of bytes TclScanElement() calls reported + * to be needed was a precise count and not an over-estimate, so long + * as the same flag values were passed to TclConvertElement(). + * + * Then we saw [35a8f1c04a], where a bug in TclScanElement() caused + * that guarantee to fail. Rather than trust there are no more bugs, + * we set the length after the loop based on what was actually written, + * an not on what was predicted. + * listPtr->length = bytesNeeded - 1; + * + */ + listPtr->bytes = ckalloc(bytesNeeded); dst = listPtr->bytes; for (i = 0; i < numElems; i++) { @@ -1999,7 +2013,10 @@ UpdateStringOfList( dst += TclConvertElement(elem, length, dst, flagPtr[i]); *dst++ = ' '; } - listPtr->bytes[listPtr->length] = '\0'; + dst[-1] = '\0'; + + /* Here is the safe setting of the string length. */ + listPtr->length = dst - 1 - listPtr->bytes; if (flagPtr != localFlags) { ckfree(flagPtr); diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 6eab7b8..d5cc7c2 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -1046,6 +1046,23 @@ TclScanElement( return 2; } +#if COMPAT + /* + * We have an established history in TclConvertElement() when quoting + * because of a leading hash character to force what would be the + * CONVERT_MASK mode into the CONVERT_BRACE mode. That is, we format + * the element #{a"b} like this: + * {#{a"b}} + * and not like this: + * \#{a\"b} + * This is inconsistent with [list x{a"b}], but we will not change that now. + * Set that preference here so that we compute a tight size requirement. + */ + if ((*src == '#') && !(*flagPtr & TCL_DONT_QUOTE_HASH)) { + preferBrace = 1; + } +#endif + if ((*p == '{') || (*p == '"')) { /* * Must escape or protect so leading character of value is not diff --git a/tests/list.test b/tests/list.test index dff5d50..2686bd7 100644 --- a/tests/list.test +++ b/tests/list.test @@ -128,6 +128,24 @@ test list-3.1 {SetListFromAny and lrange/concat results} { test list-4.1 {Bug 3173086} { string is list "{[list \\\\\}]}" } 1 +test list-4.2 {Bug 35a8f1c04a, check correct str-rep} { + set result {} + foreach i { + {#"} {#"""} {#"""""""""""""""} + "#\"{" "#\"\"\"{" "#\"\"\"\"\"\"\"\"\"\"\"\"\"\"\"\{" + "#\"}" "#\"\"\"}" "#\"\"\"\"\"\"\"\"\"\"\"\"\"\"\"\}" + } { + set list [list $i] + set list [string trim " $list "] + if {[llength $list] > 1 || $i ne [lindex $list 0]} { + lappend result "wrong string-representation of list by '$i', length: [llength $list], list: '$list'" + } + } + set result [join $result \n] +} {} +test list-4.3 {Bug 35a8f1c04a, check correct string length} { + string length [list #""] +} 5 # cleanup ::tcltest::cleanupTests -- cgit v0.12 From 730f1c88ebab905b86de41b73ebdc43aadb2138f Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 9 Nov 2018 16:48:57 +0000 Subject: silence compiler warning --- generic/tclOODefineCmds.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index f36f78b..e7c948a 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -1965,7 +1965,7 @@ TclOODefineMethodObjCmd( int isInstanceMethod = (clientData != NULL); Object *oPtr; - int isPublic; + int isPublic = 0; if (objc < 4 || objc > 5) { Tcl_WrongNumArgs(interp, 1, objv, "name ?option? args body"); -- cgit v0.12 From 3416e2d194c938d244d1404cf02d9a4331b91ac3 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 9 Nov 2018 19:03:05 +0000 Subject: Don't make tests depend on third party error messages we do not control. --- tests/httpcookie.test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/httpcookie.test b/tests/httpcookie.test index 204c263..ea29b57 100644 --- a/tests/httpcookie.test +++ b/tests/httpcookie.test @@ -170,7 +170,7 @@ test http-cookiejar-3.9 {cookie storage: class} -setup { } -returnCodes error -cleanup { catch {rename ::cookiejar ""} removeFile $f -} -result {file is encrypted or is not a database} +} -match glob -result * test http-cookiejar-3.10 {cookie storage: class} -setup { catch {rename ::cookiejar ""} set dir [makeDirectory cookiejar] -- cgit v0.12 From bd29989aabaeadc5fb048cdf88c0448bbf658c57 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 9 Nov 2018 19:05:44 +0000 Subject: policyAllow is also a cookiejar method; make tests account for it. --- tests/httpcookie.test | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/httpcookie.test b/tests/httpcookie.test index ea29b57..0facb6a 100644 --- a/tests/httpcookie.test +++ b/tests/httpcookie.test @@ -194,14 +194,14 @@ test http-cookiejar-4.2 {cookie storage: instance} -setup { cookiejar ? } -returnCodes error -cleanup { ::cookiejar destroy -} -result {unknown method "?": must be destroy, forceLoadDomainData, getCookies, lookup or storeCookie} +} -result {unknown method "?": must be destroy, forceLoadDomainData, getCookies, lookup, policyAllow or storeCookie} test http-cookiejar-4.3 {cookie storage: instance} -setup { http::cookiejar create ::cookiejar } -constraints cookiejar -body { lsort [info object methods cookiejar -all] } -cleanup { ::cookiejar destroy -} -result {destroy forceLoadDomainData getCookies lookup storeCookie} +} -result {destroy forceLoadDomainData getCookies lookup policyAllow storeCookie} test http-cookiejar-4.4 {cookie storage: instance} -setup { http::cookiejar create ::cookiejar } -constraints cookiejar -body { -- cgit v0.12 From 4dc3934516e231e6d2b5170a2b2834c77840c4e8 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 9 Nov 2018 19:14:07 +0000 Subject: update changes --- changes | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/changes b/changes index f201ac0..1bae43b 100644 --- a/changes +++ b/changes @@ -8889,4 +8889,6 @@ improvements to regexp engine from Postgres (lane,porter,fellows,seltenreich) 2018-10-29 Update tcltest package for Travis support (fellows) => tcltest 2.5.0 -- Released 8.6.9, November 9, 2018 - http://core.tcl-lang.org/tcl/ for details - +2018-11-09 (bug)[35a8f1] overlong string length of some lists (owens) + +- Released 8.6.9, November 16, 2018 - details at http://core.tcl-lang.org/tcl/ - -- cgit v0.12 From cbbc8d66b85371d63ec183c6712ae6c769ab9403 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 10 Nov 2018 07:29:08 +0000 Subject: Make the macosx build able to succeed --- macosx/GNUmakefile | 6 ++++-- tests/unixInit.test | 3 +-- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/macosx/GNUmakefile b/macosx/GNUmakefile index 54eea8e..a1b7040 100644 --- a/macosx/GNUmakefile +++ b/macosx/GNUmakefile @@ -180,8 +180,10 @@ ifeq (${BUILD_STYLE}_${EMBEDDED_BUILD},Development_) # Deployment build can be installed on top # of Development build without overwriting # the debug library - @cd "${INSTALL_ROOT}${LIBDIR}/${PRODUCT_NAME}.framework/Versions/${VERSION}" && \ - ln -f "${PRODUCT_NAME}" "${PRODUCT_NAME}_debug" + @if [ -d "${INSTALL_ROOT}${LIBDIR}/${PRODUCT_NAME}.framework/Versions/${VERSION}" ]; then \ + cd "${INSTALL_ROOT}${LIBDIR}/${PRODUCT_NAME}.framework/Versions/${VERSION}"; \ + ln -f "${PRODUCT_NAME}" "${PRODUCT_NAME}_debug"; \ + fi endif clean-${PROJECT}: %-${PROJECT}: diff --git a/tests/unixInit.test b/tests/unixInit.test index 05338ed..d0f83f3 100644 --- a/tests/unixInit.test +++ b/tests/unixInit.test @@ -336,8 +336,7 @@ test unixInit-3.1 {TclpSetInitialEncodings} -constraints { return $enc } -cleanup { unset -nocomplain env(LANG) -} -match regexp -result [expr { - ($tcl_platform(os) eq "Darwin") ? "^utf-8$" : "^iso8859-15?$"}] +} -match regexp -result {^(iso8859-15?|utf-8)$} test unixInit-3.2 {TclpSetInitialEncodings} -setup { catch {set oldlc_all $env(LC_ALL)} } -constraints {unix stdio} -body { -- cgit v0.12 From 6fe99b6e66c8a2606658ee482d9f1390ef403b78 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 10 Nov 2018 09:39:35 +0000 Subject: Tracking down test failures --- .travis.yml | 3 ++- tests/clock.test | 42 +++++++++++++++++++++++------------------- 2 files changed, 25 insertions(+), 20 deletions(-) diff --git a/.travis.yml b/.travis.yml index 230885d..d810eaf 100644 --- a/.travis.yml +++ b/.travis.yml @@ -127,4 +127,5 @@ install: - test -n "$NO_DIRECT_CONFIGURE" || ./configure ${CFGOPT} script: - make - - test -n "$NO_DIRECT_TEST" || make test + - test -n "$NO_DIRECT_TEST" || make test TESTFLAGS='-notfile socket.test' + - test -n "$NO_DIRECT_TEST" || make test TESTFLAGS='-file socket.test -verbose pt' diff --git a/tests/clock.test b/tests/clock.test index 4ec4db2..3ad5c9f 100644 --- a/tests/clock.test +++ b/tests/clock.test @@ -250,6 +250,16 @@ proc ::testClock::registry { cmd path key } { return [dict get $reg $path $key] } +proc timeWithinDuration {duration start end} { + regexp {([\d.]+)(s|ms|us)} $duration -> duration unit + set delta [expr {$end - $start}] + expr { + ($delta > 0) && ($delta <= $duration) ? + "ok" : + "test should have taken 0-$duration $unit, actually took $delta"} +} + + # Test some of the basics of [clock format] test clock-1.0 "clock format - wrong # args" { @@ -35425,7 +35435,7 @@ test clock-33.2 {clock clicks tests} { set start [clock clicks] after 10 set end [clock clicks] - expr "$end > $start" + expr {$end > $start} } {1} test clock-33.3 {clock clicks tests} { list [catch {clock clicks foo} msg] $msg @@ -35440,27 +35450,21 @@ test clock-33.4a {clock milliseconds} { } {} test clock-33.5 {clock clicks tests, millisecond timing test} { # This test can fail on a system that is so heavily loaded that - # the test takes >60 ms to run. + # the test takes >120 ms to run. set start [clock clicks -milli] after 10 set end [clock clicks -milli] - # 60 msecs seems to be the max time slice under Windows 95/98 - expr { - ($end > $start) && (($end - $start) <= 60) ? - "ok" : - "test should have taken 0-60 ms, actually took [expr $end - $start]"} + # 60 msecs seems to be the max time slice under Windows 95/98; + timeWithinDuration 120ms $start $end } {ok} test clock-33.5a {clock tests, millisecond timing test} { # This test can fail on a system that is so heavily loaded that - # the test takes >60 ms to run. + # the test takes >120 ms to run. set start [clock milliseconds] after 10 set end [clock milliseconds] # 60 msecs seems to be the max time slice under Windows 95/98 - expr { - ($end > $start) && (($end - $start) <= 60) ? - "ok" : - "test should have taken 0-60 ms, actually took [expr $end - $start]"} + timeWithinDuration 120ms $start $end } {ok} test clock-33.6 {clock clicks, milli with too much abbreviation} { list [catch { clock clicks ? } msg] $msg @@ -35471,20 +35475,20 @@ test clock-33.7 {clock clicks, milli with too much abbreviation} { test clock-33.8 {clock clicks test, microsecond timing test} { # This test can fail on a system that is so heavily loaded that - # the test takes >60 ms to run. + # the test takes >120 ms to run. set start [clock clicks -micro] after 10 set end [clock clicks -micro] - expr {($end > $start) && (($end - $start) <= 60000)} -} {1} + timeWithinDuration 120000us $start $end +} {ok} test clock-33.8a {clock test, microsecond timing test} { # This test can fail on a system that is so heavily loaded that - # the test takes >60 ms to run. + # the test takes >120 ms to run. set start [clock microseconds] after 10 set end [clock microseconds] - expr {($end > $start) && (($end - $start) <= 60000)} -} {1} + timeWithinDuration 120000us $start $end +} {ok} test clock-33.9 {clock clicks test, millis align with seconds} { set t1 [clock seconds] @@ -35826,7 +35830,7 @@ test clock-35.3 {clock seconds tests} { set start [clock seconds] after 2000 set end [clock seconds] - expr "$end > $start" + expr {$end > $start} } {1} -- cgit v0.12 From b82e9669618dda939dcedae14fdcc9f9cab087ff Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 10 Nov 2018 09:55:31 +0000 Subject: Build instructions tinkering --- .travis.yml | 30 +++++++++++++++--------------- 1 file changed, 15 insertions(+), 15 deletions(-) diff --git a/.travis.yml b/.travis.yml index d810eaf..b11e6c2 100644 --- a/.travis.yml +++ b/.travis.yml @@ -7,22 +7,22 @@ matrix: dist: trusty compiler: clang env: - - CFGOPT=--enable-shared BUILD_DIR=unix MATRIX_EVAL="" + - CFGOPT=--enable-shared BUILD_DIR=unix - os: linux dist: trusty compiler: clang env: - - CFGOPT=--disable-shared BUILD_DIR=unix MATRIX_EVAL="" + - CFGOPT=--disable-shared BUILD_DIR=unix - os: linux dist: trusty compiler: gcc env: - - CFGOPT=--enable-shared BUILD_DIR=unix MATRIX_EVAL="" + - CFGOPT=--enable-shared BUILD_DIR=unix - os: linux dist: trusty compiler: gcc env: - - CFGOPT=--disable-shared BUILD_DIR=unix MATRIX_EVAL="" + - CFGOPT=--disable-shared BUILD_DIR=unix - os: linux dist: trusty compiler: gcc @@ -47,7 +47,7 @@ matrix: - CC=gcc-5 BUILD_DIR=unix MATRIX_EVAL="CC=gcc-5" - os: linux dist: trusty - compiler: gcc + compiler: gcc-6 addons: apt: sources: @@ -55,7 +55,7 @@ matrix: packages: - g++-6 env: - - CC=gcc-6 BUILD_DIR=unix MATRIX_EVAL="CC=gcc-6" + - BUILD_DIR=unix - os: linux dist: trusty compiler: gcc @@ -70,23 +70,23 @@ matrix: - os: osx osx_image: xcode8 env: - - BUILD_DIR=unix MATRIX_EVAL="" + - BUILD_DIR=unix - os: osx osx_image: xcode8 env: - - BUILD_DIR=macosx MATRIX_EVAL="" NO_DIRECT_CONFIGURE=1 + - BUILD_DIR=macosx NO_DIRECT_CONFIGURE=1 - os: osx osx_image: xcode9 env: - - BUILD_DIR=macosx MATRIX_EVAL="" NO_DIRECT_CONFIGURE=1 + - BUILD_DIR=macosx NO_DIRECT_CONFIGURE=1 - os: osx osx_image: xcode10 env: - - BUILD_DIR=macosx MATRIX_EVAL="" NO_DIRECT_CONFIGURE=1 + - BUILD_DIR=macosx NO_DIRECT_CONFIGURE=1 ### C builds not currently supported on Windows instances # - os: windows # env: -# - BUILD_DIR=win MATRIX_EVAL="" +# - BUILD_DIR=win ### ... so proxy with a Mingw cross-compile # Test with mingw-w64 (32 bit) - os: linux @@ -102,7 +102,7 @@ matrix: - gcc-multilib - wine env: - - BUILD_DIR=win MATRIX_EVAL="" CFGOPT=--host=i686-w64-mingw32 NO_DIRECT_TEST=1 + - BUILD_DIR=win CFGOPT=--host=i686-w64-mingw32 NO_DIRECT_TEST=1 # Test with mingw-w64 (64 bit) - os: linux dist: trusty @@ -116,7 +116,7 @@ matrix: - gcc-mingw-w64 - wine env: - - BUILD_DIR=win MATRIX_EVAL="" CFGOPT="--host=x86_64-w64-mingw32 --enable-64bit" NO_DIRECT_TEST=1 + - BUILD_DIR=win CFGOPT="--host=x86_64-w64-mingw32 --enable-64bit" NO_DIRECT_TEST=1 before_install: - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then rvm get stable; fi @@ -127,5 +127,5 @@ install: - test -n "$NO_DIRECT_CONFIGURE" || ./configure ${CFGOPT} script: - make - - test -n "$NO_DIRECT_TEST" || make test TESTFLAGS='-notfile socket.test' - - test -n "$NO_DIRECT_TEST" || make test TESTFLAGS='-file socket.test -verbose pt' + - test -n "$NO_DIRECT_TEST" || make test TESTFLAGS='-notfile socket.test' styles=develop + - test -n "$NO_DIRECT_TEST" || make test TESTFLAGS='-file socket.test -verbose pt' styles=develop -- cgit v0.12 From 13f704914ae916a8e298edfa0d730482b1c74d89 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 11 Nov 2018 15:07:12 +0000 Subject: Clean up Travis config now that it passes --- .travis.yml | 21 ++++++++++----------- 1 file changed, 10 insertions(+), 11 deletions(-) diff --git a/.travis.yml b/.travis.yml index b11e6c2..a2a59fc 100644 --- a/.travis.yml +++ b/.travis.yml @@ -7,7 +7,7 @@ matrix: dist: trusty compiler: clang env: - - CFGOPT=--enable-shared BUILD_DIR=unix + - BUILD_DIR=unix - os: linux dist: trusty compiler: clang @@ -17,7 +17,7 @@ matrix: dist: trusty compiler: gcc env: - - CFGOPT=--enable-shared BUILD_DIR=unix + - BUILD_DIR=unix - os: linux dist: trusty compiler: gcc @@ -25,7 +25,7 @@ matrix: - CFGOPT=--disable-shared BUILD_DIR=unix - os: linux dist: trusty - compiler: gcc + compiler: gcc-4.9 addons: apt: sources: @@ -33,10 +33,10 @@ matrix: packages: - g++-4.9 env: - - CC=gcc-4.9 BUILD_DIR=unix MATRIX_EVAL="CC=gcc-4.9" + - BUILD_DIR=unix - os: linux dist: trusty - compiler: gcc + compiler: gcc-5 addons: apt: sources: @@ -44,7 +44,7 @@ matrix: packages: - g++-5 env: - - CC=gcc-5 BUILD_DIR=unix MATRIX_EVAL="CC=gcc-5" + - BUILD_DIR=unix - os: linux dist: trusty compiler: gcc-6 @@ -58,7 +58,7 @@ matrix: - BUILD_DIR=unix - os: linux dist: trusty - compiler: gcc + compiler: gcc-7 addons: apt: sources: @@ -66,7 +66,7 @@ matrix: packages: - g++-7 env: - - CC=gcc-7 BUILD_DIR=unix MATRIX_EVAL="CC=gcc-7" + - BUILD_DIR=unix - os: osx osx_image: xcode8 env: @@ -120,12 +120,11 @@ matrix: before_install: - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then rvm get stable; fi - - eval "${MATRIX_EVAL}" - export ERROR_ON_FAILURES=1 - cd ${BUILD_DIR} install: - test -n "$NO_DIRECT_CONFIGURE" || ./configure ${CFGOPT} script: - make - - test -n "$NO_DIRECT_TEST" || make test TESTFLAGS='-notfile socket.test' styles=develop - - test -n "$NO_DIRECT_TEST" || make test TESTFLAGS='-file socket.test -verbose pt' styles=develop + # The styles=develop avoids some weird problems on OSX + - test -n "$NO_DIRECT_TEST" || make test styles=develop -- cgit v0.12 From 44fd5b0f834eb22e1ced62f9e03badb0163e88a7 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 11 Nov 2018 16:55:53 +0000 Subject: Fix builds on Travis. --- .travis.yml | 56 ++++++++++++++++++++++++----------------------------- tests/unixInit.test | 3 +-- 2 files changed, 26 insertions(+), 33 deletions(-) diff --git a/.travis.yml b/.travis.yml index 64801ec..2ff31c0 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,32 +1,33 @@ -dist: trusty sudo: false language: c + matrix: include: - os: linux + dist: trusty compiler: clang env: - - MATRIX_EVAL="" - BUILD_DIR=unix - os: linux + dist: trusty compiler: clang env: - - MATRIX_EVAL="" - - BUILD_DIR=unix - CFGOPT=--disable-shared + - BUILD_DIR=unix - os: linux + dist: trusty compiler: gcc env: - - MATRIX_EVAL="" - BUILD_DIR=unix - os: linux + dist: trusty compiler: gcc env: - - MATRIX_EVAL="" - - BUILD_DIR=unix - CFGOPT=--disable-shared + - BUILD_DIR=unix - os: linux - compiler: gcc + dist: trusty + compiler: gcc-4.9 addons: apt: sources: @@ -34,10 +35,10 @@ matrix: packages: - g++-4.9 env: - - MATRIX_EVAL="CC=gcc-4.9" - BUILD_DIR=unix - os: linux - compiler: gcc + dist: trusty + compiler: gcc-5 addons: apt: sources: @@ -45,10 +46,10 @@ matrix: packages: - g++-5 env: - - MATRIX_EVAL="CC=gcc-5" - BUILD_DIR=unix - os: linux - compiler: gcc + dist: trusty + compiler: gcc-6 addons: apt: sources: @@ -56,10 +57,10 @@ matrix: packages: - g++-6 env: - - MATRIX_EVAL="CC=gcc-6" - BUILD_DIR=unix - os: linux - compiler: gcc + dist: trusty + compiler: gcc-7 addons: apt: sources: @@ -67,33 +68,34 @@ matrix: packages: - g++-7 env: - - MATRIX_EVAL="CC=gcc-7" - BUILD_DIR=unix - os: osx osx_image: xcode8 env: - - MATRIX_EVAL="" - BUILD_DIR=unix - os: osx osx_image: xcode8 env: - - MATRIX_EVAL="" - BUILD_DIR=macosx - NO_DIRECT_CONFIGURE=1 - os: osx osx_image: xcode9 env: - - MATRIX_EVAL="" - BUILD_DIR=macosx - NO_DIRECT_CONFIGURE=1 - os: osx osx_image: xcode10 env: - - MATRIX_EVAL="" - BUILD_DIR=macosx - NO_DIRECT_CONFIGURE=1 +### C builds not currently directly supported on Windows instances +# - os: windows +# env: +# - BUILD_DIR=win +### ... so proxy with a Mingw cross-compile # Test with mingw-w64 (32 bit) - os: linux + dist: trusty compiler: i686-w64-mingw32-gcc addons: apt: @@ -105,13 +107,12 @@ matrix: - gcc-multilib - wine env: - - MATRIX_EVAL="" - BUILD_DIR=win - CFGOPT=--host=i686-w64-mingw32 - NO_DIRECT_TEST=1 - # Test with mingw-w64 (64 bit) - os: linux + dist: trusty compiler: x86_64-w64-mingw32-gcc addons: apt: @@ -122,24 +123,17 @@ matrix: - gcc-mingw-w64 - wine env: - - MATRIX_EVAL="" - BUILD_DIR=win - - CFGOPT=--host=x86_64-w64-mingw32 --enable-64bit + - CFGOPT="--host=x86_64-w64-mingw32 --enable-64bit" - NO_DIRECT_TEST=1 -### C builds not currently supported on Windows instances -# - os: windows -# env: -# - MATRIX_EVAL="" -# - BUILD_DIR=win - before_install: - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then rvm get stable; fi - - eval "${MATRIX_EVAL}" - export ERROR_ON_FAILURES=1 - cd ${BUILD_DIR} install: - test -n "$NO_DIRECT_CONFIGURE" || ./configure ${CFGOPT} script: - make - - test -n "$NO_DIRECT_TEST" || make test + # The styles=develop avoids some weird problems on OSX + - test -n "$NO_DIRECT_TEST" || make test styles=develop diff --git a/tests/unixInit.test b/tests/unixInit.test index 1014d52..101a3b2 100644 --- a/tests/unixInit.test +++ b/tests/unixInit.test @@ -349,8 +349,7 @@ test unixInit-3.1 {TclpSetInitialEncodings} -constraints { close $f unset env(LANG) set enc -} -match regexp -result [expr { - ($tcl_platform(os) eq "Darwin") ? "^utf-8$" : "^iso8859-15?$"}] +} -match regexp -result {^(iso8859-15?|utf-8)$} test unixInit-3.2 {TclpSetInitialEncodings} {unix stdio} { set env(LANG) japanese catch {set oldlc_all $env(LC_ALL)} -- cgit v0.12 From 18b503297b6aa3a5d5b1c4827896daa930c1155a Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 12 Nov 2018 09:26:25 +0000 Subject: Fix brokenness in GNUmakefile --- macosx/GNUmakefile | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/macosx/GNUmakefile b/macosx/GNUmakefile index 7d19fc6..cbe081a 100644 --- a/macosx/GNUmakefile +++ b/macosx/GNUmakefile @@ -180,8 +180,10 @@ ifeq (${BUILD_STYLE}_${EMBEDDED_BUILD},Development_) # Deployment build can be installed on top # of Development build without overwriting # the debug library - @cd "${INSTALL_ROOT}${LIBDIR}/${PRODUCT_NAME}.framework/Versions/${VERSION}" && \ - ln -f "${PRODUCT_NAME}" "${PRODUCT_NAME}_debug" + @if [ -d "${INSTALL_ROOT}${LIBDIR}/${PRODUCT_NAME}.framework/Versions/${VERSION}" ]; then \ + cd "${INSTALL_ROOT}${LIBDIR}/${PRODUCT_NAME}.framework/Versions/${VERSION}"; \ + ln -f "${PRODUCT_NAME}" "${PRODUCT_NAME}_debug"; \ + fi endif clean-${PROJECT}: %-${PROJECT}: -- cgit v0.12 From fa2ceeffffa5a2d4e4de3648f253bedc3d95e22d Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 12 Nov 2018 09:48:17 +0000 Subject: Make cookiejar tests skip gracefully --- tests/httpcookie.test | 127 ++++++++++++++++++++++++++------------------------ 1 file changed, 66 insertions(+), 61 deletions(-) diff --git a/tests/httpcookie.test b/tests/httpcookie.test index 0facb6a..d4acad9 100644 --- a/tests/httpcookie.test +++ b/tests/httpcookie.test @@ -12,39 +12,44 @@ package require tcltest 2 namespace import -force ::tcltest::* +testConstraint sqlite3 [expr {![catch { + package require sqlite3 +}]}] testConstraint cookiejar [expr {![catch { - package require cookiejar + if {[testConstraint sqlite3]} { + package require cookiejar + } }]}] -test http-cookiejar-1.1 {cookie storage: packaging} cookiejar { +test http-cookiejar-1.1 {cookie storage: packaging} {sqlite3 cookiejar} { package require cookiejar } 0.1 -test http-cookiejar-1.2 {cookie storage: packaging} cookiejar { +test http-cookiejar-1.2 {cookie storage: packaging} {sqlite3 cookiejar} { package require cookiejar package require cookiejar } 0.1 -test http-cookiejar-2.1 {cookie storage: basics} -constraints cookiejar -body { +test http-cookiejar-2.1 {cookie storage: basics} -constraints {sqlite3 cookiejar} -body { http::cookiejar } -returnCodes error -result {wrong # args: should be "http::cookiejar method ?arg ...?"} -test http-cookiejar-2.2 {cookie storage: basics} -constraints cookiejar -body { +test http-cookiejar-2.2 {cookie storage: basics} -constraints {sqlite3 cookiejar} -body { http::cookiejar ? } -returnCodes error -result {unknown method "?": must be configure, create, destroy or new} -test http-cookiejar-2.3 {cookie storage: basics} cookiejar { +test http-cookiejar-2.3 {cookie storage: basics} {sqlite3 cookiejar} { http::cookiejar configure } {-domainfile -domainlist -domainrefresh -loglevel -offline -purgeold -retain -vacuumtrigger} -test http-cookiejar-2.4 {cookie storage: basics} -constraints cookiejar -body { +test http-cookiejar-2.4 {cookie storage: basics} -constraints {sqlite3 cookiejar} -body { http::cookiejar configure a b c d e } -returnCodes error -result {wrong # args: should be "http::cookiejar configure ?optionName? ?optionValue?"} -test http-cookiejar-2.5 {cookie storage: basics} -constraints cookiejar -body { +test http-cookiejar-2.5 {cookie storage: basics} -constraints {sqlite3 cookiejar} -body { http::cookiejar configure a } -returnCodes error -result {bad option "a": must be -domainfile, -domainlist, -domainrefresh, -loglevel, -offline, -purgeold, -retain, or -vacuumtrigger} -test http-cookiejar-2.6 {cookie storage: basics} -constraints cookiejar -body { +test http-cookiejar-2.6 {cookie storage: basics} -constraints {sqlite3 cookiejar} -body { http::cookiejar configure -d } -returnCodes error -result {ambiguous option "-d": must be -domainfile, -domainlist, -domainrefresh, -loglevel, -offline, -purgeold, -retain, or -vacuumtrigger} test http-cookiejar-2.7 {cookie storage: basics} -setup { set old [http::cookiejar configure -loglevel] -} -constraints cookiejar -body { +} -constraints {sqlite3 cookiejar} -body { list [http::cookiejar configure -loglevel] \ [http::cookiejar configure -loglevel debug] \ [http::cookiejar configure -loglevel] \ @@ -55,7 +60,7 @@ test http-cookiejar-2.7 {cookie storage: basics} -setup { } -result {info debug debug error error} test http-cookiejar-2.8 {cookie storage: basics} -setup { set old [http::cookiejar configure -loglevel] -} -constraints cookiejar -body { +} -constraints {sqlite3 cookiejar} -body { list [http::cookiejar configure -loglevel] \ [http::cookiejar configure -loglevel d] \ [http::cookiejar configure -loglevel i] \ @@ -64,40 +69,40 @@ test http-cookiejar-2.8 {cookie storage: basics} -setup { } -cleanup { http::cookiejar configure -loglevel $old } -result {info debug info warn error} -test http-cookiejar-2.9 {cookie storage: basics} -constraints cookiejar -body { +test http-cookiejar-2.9 {cookie storage: basics} -constraints {sqlite3 cookiejar} -body { http::cookiejar configure -off } -match glob -result * test http-cookiejar-2.10 {cookie storage: basics} -setup { set oldval [http::cookiejar configure -offline] -} -constraints cookiejar -body { +} -constraints {sqlite3 cookiejar} -body { http::cookiejar configure -offline true } -cleanup { catch {http::cookiejar configure -offline $oldval} } -result 1 test http-cookiejar-2.11 {cookie storage: basics} -setup { set oldval [http::cookiejar configure -offline] -} -constraints cookiejar -body { +} -constraints {sqlite3 cookiejar} -body { http::cookiejar configure -offline nonbool } -cleanup { catch {http::cookiejar configure -offline $oldval} } -returnCodes error -result {expected boolean value but got "nonbool"} test http-cookiejar-2.12 {cookie storage: basics} -setup { set oldval [http::cookiejar configure -purgeold] -} -constraints cookiejar -body { +} -constraints {sqlite3 cookiejar} -body { http::cookiejar configure -purge nonint } -cleanup { catch {http::cookiejar configure -purgeold $oldval} } -returnCodes error -result {expected positive integer but got "nonint"} test http-cookiejar-2.13 {cookie storage: basics} -setup { set oldval [http::cookiejar configure -domainrefresh] -} -constraints cookiejar -body { +} -constraints {sqlite3 cookiejar} -body { http::cookiejar configure -domainref nonint } -cleanup { catch {http::cookiejar configure -domainrefresh $oldval} } -returnCodes error -result {expected positive integer but got "nonint"} test http-cookiejar-2.14 {cookie storage: basics} -setup { set oldval [http::cookiejar configure -domainrefresh] -} -constraints cookiejar -body { +} -constraints {sqlite3 cookiejar} -body { http::cookiejar configure -domainref -42 } -cleanup { catch {http::cookiejar configure -domainrefresh $oldval} @@ -106,7 +111,7 @@ test http-cookiejar-2.15 {cookie storage: basics} -setup { set oldval [http::cookiejar configure -domainrefresh] set result unset set tracer [http::cookiejar create tracer] -} -constraints cookiejar -body { +} -constraints {sqlite3 cookiejar} -body { oo::objdefine $tracer method PostponeRefresh {} { set ::result set next @@ -118,28 +123,28 @@ test http-cookiejar-2.15 {cookie storage: basics} -setup { catch {http::cookiejar configure -domainrefresh $oldval} } -result set -test http-cookiejar-3.1 {cookie storage: class} cookiejar { +test http-cookiejar-3.1 {cookie storage: class} {sqlite3 cookiejar} { info object isa object http::cookiejar } 1 -test http-cookiejar-3.2 {cookie storage: class} cookiejar { +test http-cookiejar-3.2 {cookie storage: class} {sqlite3 cookiejar} { info object isa class http::cookiejar } 1 -test http-cookiejar-3.3 {cookie storage: class} cookiejar { +test http-cookiejar-3.3 {cookie storage: class} {sqlite3 cookiejar} { lsort [info object methods http::cookiejar] } {configure} -test http-cookiejar-3.4 {cookie storage: class} cookiejar { +test http-cookiejar-3.4 {cookie storage: class} {sqlite3 cookiejar} { lsort [info object methods http::cookiejar -all] } {configure create destroy new} test http-cookiejar-3.5 {cookie storage: class} -setup { catch {rename ::cookiejar ""} -} -constraints cookiejar -body { +} -constraints {sqlite3 cookiejar} -body { namespace eval :: {http::cookiejar create cookiejar} } -cleanup { catch {rename ::cookiejar ""} } -result ::cookiejar test http-cookiejar-3.6 {cookie storage: class} -setup { catch {rename ::cookiejar ""} -} -constraints cookiejar -body { +} -constraints {sqlite3 cookiejar} -body { list [http::cookiejar create ::cookiejar] [info commands ::cookiejar] \ [::cookiejar destroy] [info commands ::cookiejar] } -cleanup { @@ -147,7 +152,7 @@ test http-cookiejar-3.6 {cookie storage: class} -setup { } -result {::cookiejar ::cookiejar {} {}} test http-cookiejar-3.7 {cookie storage: class} -setup { catch {rename ::cookiejar ""} -} -constraints cookiejar -body { +} -constraints {sqlite3 cookiejar} -body { http::cookiejar create ::cookiejar foo bar } -returnCodes error -cleanup { catch {rename ::cookiejar ""} @@ -156,7 +161,7 @@ test http-cookiejar-3.8 {cookie storage: class} -setup { catch {rename ::cookiejar ""} set f [makeFile "" cookiejar] file delete $f -} -constraints cookiejar -body { +} -constraints {sqlite3 cookiejar} -body { http::cookiejar create ::cookiejar $f } -cleanup { catch {rename ::cookiejar ""} @@ -165,7 +170,7 @@ test http-cookiejar-3.8 {cookie storage: class} -setup { test http-cookiejar-3.9 {cookie storage: class} -setup { catch {rename ::cookiejar ""} set f [makeFile "bogus content for a database" cookiejar] -} -constraints cookiejar -body { +} -constraints {sqlite3 cookiejar} -body { http::cookiejar create ::cookiejar $f } -returnCodes error -cleanup { catch {rename ::cookiejar ""} @@ -174,7 +179,7 @@ test http-cookiejar-3.9 {cookie storage: class} -setup { test http-cookiejar-3.10 {cookie storage: class} -setup { catch {rename ::cookiejar ""} set dir [makeDirectory cookiejar] -} -constraints cookiejar -body { +} -constraints {sqlite3 cookiejar} -body { http::cookiejar create ::cookiejar $dir } -returnCodes error -cleanup { catch {rename ::cookiejar ""} @@ -183,49 +188,49 @@ test http-cookiejar-3.10 {cookie storage: class} -setup { test http-cookiejar-4.1 {cookie storage: instance} -setup { http::cookiejar create ::cookiejar -} -constraints cookiejar -body { +} -constraints {sqlite3 cookiejar} -body { cookiejar } -returnCodes error -cleanup { ::cookiejar destroy } -result {wrong # args: should be "cookiejar method ?arg ...?"} test http-cookiejar-4.2 {cookie storage: instance} -setup { http::cookiejar create ::cookiejar -} -constraints cookiejar -body { +} -constraints {sqlite3 cookiejar} -body { cookiejar ? } -returnCodes error -cleanup { ::cookiejar destroy } -result {unknown method "?": must be destroy, forceLoadDomainData, getCookies, lookup, policyAllow or storeCookie} test http-cookiejar-4.3 {cookie storage: instance} -setup { http::cookiejar create ::cookiejar -} -constraints cookiejar -body { +} -constraints {sqlite3 cookiejar} -body { lsort [info object methods cookiejar -all] } -cleanup { ::cookiejar destroy } -result {destroy forceLoadDomainData getCookies lookup policyAllow storeCookie} test http-cookiejar-4.4 {cookie storage: instance} -setup { http::cookiejar create ::cookiejar -} -constraints cookiejar -body { +} -constraints {sqlite3 cookiejar} -body { cookiejar getCookies } -returnCodes error -cleanup { ::cookiejar destroy } -result {wrong # args: should be "cookiejar getCookies proto host path"} test http-cookiejar-4.5 {cookie storage} -setup { http::cookiejar create ::cookiejar -} -constraints cookiejar -body { +} -constraints {sqlite3 cookiejar} -body { cookiejar getCookies http www.example.com / } -cleanup { ::cookiejar destroy } -result {} test http-cookiejar-4.6 {cookie storage: instance} -setup { http::cookiejar create ::cookiejar -} -constraints cookiejar -body { +} -constraints {sqlite3 cookiejar} -body { cookiejar storeCookie } -returnCodes error -cleanup { ::cookiejar destroy } -result {wrong # args: should be "cookiejar storeCookie options"} test http-cookiejar-4.7 {cookie storage: instance} -setup { http::cookiejar create ::cookiejar -} -constraints cookiejar -body { +} -constraints {sqlite3 cookiejar} -body { cookiejar storeCookie { key foo value bar @@ -241,7 +246,7 @@ test http-cookiejar-4.7 {cookie storage: instance} -setup { test http-cookiejar-4.8 {cookie storage: instance} -setup { http::cookiejar create ::cookiejar oo::objdefine ::cookiejar export Database -} -constraints cookiejar -body { +} -constraints {sqlite3 cookiejar} -body { cookiejar storeCookie { key foo value bar @@ -259,7 +264,7 @@ test http-cookiejar-4.8 {cookie storage: instance} -setup { test http-cookiejar-4.9 {cookie storage: instance} -setup { http::cookiejar create ::cookiejar oo::objdefine ::cookiejar export Database -} -constraints cookiejar -body { +} -constraints {sqlite3 cookiejar} -body { cookiejar storeCookie { key foo value bar @@ -276,7 +281,7 @@ test http-cookiejar-4.9 {cookie storage: instance} -setup { } -result 0 test http-cookiejar-4.10 {cookie storage: instance} -setup { http::cookiejar create ::cookiejar -} -constraints cookiejar -body { +} -constraints {sqlite3 cookiejar} -body { cookiejar storeCookie [dict replace { key foo value bar @@ -292,7 +297,7 @@ test http-cookiejar-4.10 {cookie storage: instance} -setup { test http-cookiejar-4.11 {cookie storage: instance} -setup { http::cookiejar create ::cookiejar oo::objdefine ::cookiejar export Database -} -constraints cookiejar -body { +} -constraints {sqlite3 cookiejar} -body { cookiejar storeCookie [dict replace { key foo value bar @@ -310,7 +315,7 @@ test http-cookiejar-4.11 {cookie storage: instance} -setup { test http-cookiejar-4.12 {cookie storage: instance} -setup { http::cookiejar create ::cookiejar oo::objdefine ::cookiejar export Database -} -constraints cookiejar -body { +} -constraints {sqlite3 cookiejar} -body { cookiejar storeCookie [dict replace { key foo value bar @@ -328,7 +333,7 @@ test http-cookiejar-4.12 {cookie storage: instance} -setup { test http-cookiejar-4.13 {cookie storage: instance} -setup { http::cookiejar create ::cookiejar set result {} -} -constraints cookiejar -body { +} -constraints {sqlite3 cookiejar} -body { lappend result [cookiejar getCookies http www.example.com /] cookiejar storeCookie { key foo @@ -346,7 +351,7 @@ test http-cookiejar-4.13 {cookie storage: instance} -setup { test http-cookiejar-4.14 {cookie storage: instance} -setup { http::cookiejar create ::cookiejar set result {} -} -constraints cookiejar -body { +} -constraints {sqlite3 cookiejar} -body { lappend result [cookiejar getCookies http www.example.com /] cookiejar storeCookie [dict replace { key foo @@ -364,7 +369,7 @@ test http-cookiejar-4.14 {cookie storage: instance} -setup { test http-cookiejar-4.15 {cookie storage: instance} -setup { http::cookiejar create ::cookiejar set result {} -} -constraints cookiejar -body { +} -constraints {sqlite3 cookiejar} -body { lappend result [cookiejar getCookies http www.example.com /] cookiejar storeCookie { key foo @@ -391,7 +396,7 @@ test http-cookiejar-4.15 {cookie storage: instance} -setup { test http-cookiejar-4.16 {cookie storage: instance} -setup { http::cookiejar create ::cookiejar set result {} -} -constraints cookiejar -body { +} -constraints {sqlite3 cookiejar} -body { lappend result [cookiejar getCookies http www.example.com /] cookiejar storeCookie { key foo1 @@ -417,7 +422,7 @@ test http-cookiejar-4.16 {cookie storage: instance} -setup { } -result {{} {foo1 bar foo2 bar}} test http-cookiejar-4.17 {cookie storage: instance} -setup { http::cookiejar create ::cookiejar -} -constraints cookiejar -body { +} -constraints {sqlite3 cookiejar} -body { cookiejar lookup a b c d } -returnCodes error -cleanup { ::cookiejar destroy @@ -425,7 +430,7 @@ test http-cookiejar-4.17 {cookie storage: instance} -setup { test http-cookiejar-4.18 {cookie storage: instance} -setup { http::cookiejar create ::cookiejar set result {} -} -constraints cookiejar -body { +} -constraints {sqlite3 cookiejar} -body { lappend result [cookiejar lookup] lappend result [cookiejar lookup www.example.com] lappend result [catch {cookiejar lookup www.example.com foo} value] $value @@ -447,7 +452,7 @@ test http-cookiejar-4.18 {cookie storage: instance} -setup { test http-cookiejar-4.19 {cookie storage: instance} -setup { http::cookiejar create ::cookiejar set result {} -} -constraints cookiejar -body { +} -constraints {sqlite3 cookiejar} -body { cookiejar storeCookie { key foo value bar @@ -477,7 +482,7 @@ test http-cookiejar-4.19 {cookie storage: instance} -setup { test http-cookiejar-4.20 {cookie storage: instance} -setup { http::cookiejar create ::cookiejar set result {} -} -constraints cookiejar -body { +} -constraints {sqlite3 cookiejar} -body { cookiejar storeCookie { key foo1 value bar1 @@ -506,7 +511,7 @@ test http-cookiejar-4.20 {cookie storage: instance} -setup { test http-cookiejar-4.21 {cookie storage: instance} -setup { http::cookiejar create ::cookiejar set result {} -} -constraints cookiejar -body { +} -constraints {sqlite3 cookiejar} -body { cookiejar storeCookie { key foo1 value bar1 @@ -535,7 +540,7 @@ test http-cookiejar-4.21 {cookie storage: instance} -setup { test http-cookiejar-4.22 {cookie storage: instance} -setup { http::cookiejar create ::cookiejar set result {} -} -constraints cookiejar -body { +} -constraints {sqlite3 cookiejar} -body { cookiejar forceLoadDomainData x y z } -returnCodes error -cleanup { ::cookiejar destroy @@ -543,14 +548,14 @@ test http-cookiejar-4.22 {cookie storage: instance} -setup { test http-cookiejar-4.23 {cookie storage: instance} -setup { http::cookiejar create ::cookiejar set result {} -} -constraints cookiejar -body { +} -constraints {sqlite3 cookiejar} -body { cookiejar forceLoadDomainData } -cleanup { ::cookiejar destroy } -result {} test http-cookiejar-4.23.a {cookie storage: instance} -setup { set off [http::cookiejar configure -offline] -} -constraints cookiejar -body { +} -constraints {sqlite3 cookiejar} -body { http::cookiejar configure -offline 1 [http::cookiejar create ::cookiejar] destroy } -cleanup { @@ -559,7 +564,7 @@ test http-cookiejar-4.23.a {cookie storage: instance} -setup { } -result {} test http-cookiejar-4.23.b {cookie storage: instance} -setup { set off [http::cookiejar configure -offline] -} -constraints cookiejar -body { +} -constraints {sqlite3 cookiejar} -body { http::cookiejar configure -offline 0 [http::cookiejar create ::cookiejar] destroy } -cleanup { @@ -570,7 +575,7 @@ test http-cookiejar-4.23.b {cookie storage: instance} -setup { test http-cookiejar-5.1 {cookie storage: constraints} -setup { http::cookiejar create ::cookiejar cookiejar forceLoadDomainData -} -constraints cookiejar -body { +} -constraints {sqlite3 cookiejar} -body { cookiejar storeCookie { key foo value bar @@ -587,7 +592,7 @@ test http-cookiejar-5.1 {cookie storage: constraints} -setup { test http-cookiejar-5.2 {cookie storage: constraints} -setup { http::cookiejar create ::cookiejar cookiejar forceLoadDomainData -} -constraints cookiejar -body { +} -constraints {sqlite3 cookiejar} -body { cookiejar storeCookie { key foo value bar @@ -604,7 +609,7 @@ test http-cookiejar-5.2 {cookie storage: constraints} -setup { test http-cookiejar-5.3 {cookie storage: constraints} -setup { http::cookiejar create ::cookiejar cookiejar forceLoadDomainData -} -constraints cookiejar -body { +} -constraints {sqlite3 cookiejar} -body { cookiejar storeCookie { key foo1 value bar @@ -630,7 +635,7 @@ test http-cookiejar-5.3 {cookie storage: constraints} -setup { test http-cookiejar-5.4 {cookie storage: constraints} -setup { http::cookiejar create ::cookiejar cookiejar forceLoadDomainData -} -constraints cookiejar -body { +} -constraints {sqlite3 cookiejar} -body { cookiejar storeCookie { key foo value bar1 @@ -656,7 +661,7 @@ test http-cookiejar-5.4 {cookie storage: constraints} -setup { test http-cookiejar-5.5 {cookie storage: constraints} -setup { http::cookiejar create ::cookiejar cookiejar forceLoadDomainData -} -constraints cookiejar -body { +} -constraints {sqlite3 cookiejar} -body { cookiejar storeCookie { key foo1 value 1 @@ -754,7 +759,7 @@ test http-cookiejar-6.1 {cookie storage: expiry and lookup} -setup { global result lappend result [lsort [lmap {k v} $cookies {set v}]] } -} -constraints cookiejar -body { +} -constraints {sqlite3 cookiejar} -body { values [cookiejar getCookies http www.example.com /] cookiejar storeCookie { key foo @@ -810,7 +815,7 @@ test http-cookiejar-7.1 {cookie storage: persistence of persistent cookies} -set catch {rename ::cookiejar ""} set f [makeFile "" cookiejar] file delete $f -} -constraints cookiejar -body { +} -constraints {sqlite3 cookiejar} -body { http::cookiejar create ::cookiejar $f ::cookiejar destroy http::cookiejar create ::cookiejar $f @@ -823,7 +828,7 @@ test http-cookiejar-7.2 {cookie storage: persistence of persistent cookies} -set set f [makeFile "" cookiejar] file delete $f set result {} -} -constraints cookiejar -body { +} -constraints {sqlite3 cookiejar} -body { http::cookiejar create ::cookiejar $f cookiejar storeCookie [dict replace { key foo -- cgit v0.12 From fc38a30572b56187498c4cc8f3721a26e919cdcf Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 12 Nov 2018 09:49:24 +0000 Subject: Cleaner way of writing environment variables --- .travis.yml | 23 ++++++++++++++++------- 1 file changed, 16 insertions(+), 7 deletions(-) diff --git a/.travis.yml b/.travis.yml index a2a59fc..947e858 100644 --- a/.travis.yml +++ b/.travis.yml @@ -12,7 +12,8 @@ matrix: dist: trusty compiler: clang env: - - CFGOPT=--disable-shared BUILD_DIR=unix + - CFGOPT=--disable-shared + - BUILD_DIR=unix - os: linux dist: trusty compiler: gcc @@ -22,7 +23,8 @@ matrix: dist: trusty compiler: gcc env: - - CFGOPT=--disable-shared BUILD_DIR=unix + - CFGOPT=--disable-shared + - BUILD_DIR=unix - os: linux dist: trusty compiler: gcc-4.9 @@ -74,15 +76,18 @@ matrix: - os: osx osx_image: xcode8 env: - - BUILD_DIR=macosx NO_DIRECT_CONFIGURE=1 + - BUILD_DIR=macosx + - NO_DIRECT_CONFIGURE=1 - os: osx osx_image: xcode9 env: - - BUILD_DIR=macosx NO_DIRECT_CONFIGURE=1 + - BUILD_DIR=macosx + - NO_DIRECT_CONFIGURE=1 - os: osx osx_image: xcode10 env: - - BUILD_DIR=macosx NO_DIRECT_CONFIGURE=1 + - BUILD_DIR=macosx + - NO_DIRECT_CONFIGURE=1 ### C builds not currently supported on Windows instances # - os: windows # env: @@ -102,7 +107,9 @@ matrix: - gcc-multilib - wine env: - - BUILD_DIR=win CFGOPT=--host=i686-w64-mingw32 NO_DIRECT_TEST=1 + - BUILD_DIR=win + - CFGOPT=--host=i686-w64-mingw32 + - NO_DIRECT_TEST=1 # Test with mingw-w64 (64 bit) - os: linux dist: trusty @@ -116,7 +123,9 @@ matrix: - gcc-mingw-w64 - wine env: - - BUILD_DIR=win CFGOPT="--host=x86_64-w64-mingw32 --enable-64bit" NO_DIRECT_TEST=1 + - BUILD_DIR=win + - CFGOPT="--host=x86_64-w64-mingw32 --enable-64bit" + - NO_DIRECT_TEST=1 before_install: - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then rvm get stable; fi -- cgit v0.12 From 4402274b45049b12d8ef66d4b94baa29decfd9c5 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 14 Nov 2018 03:31:58 +0000 Subject: Make socket tests less likely to hang on OSX --- tests/socket.test | 1036 ++++++++++++++++++++++++++--------------------------- 1 file changed, 501 insertions(+), 535 deletions(-) diff --git a/tests/socket.test b/tests/socket.test index a3e5704..477ecf6 100644 --- a/tests/socket.test +++ b/tests/socket.test @@ -272,6 +272,9 @@ proc getPort sock { lindex [fconfigure $sock -sockname] 2 } +# Some tests in this file are known to hang *occasionally* on OSX; stop the +# worst offenders. +testConstraint notOSX [expr {$::tcl_platform(os) ne "Darwin"}] # ---------------------------------------------------------------------- @@ -1823,557 +1826,522 @@ catch {close $commandSocket} catch {close $remoteProcChan} } unset ::tcl::unsupported::socketAF -test socket-14.0.0 {[socket -async] when server only listens on IPv4} \ - -constraints {socket supported_inet localhost_v4} \ - -setup { - proc accept {s a p} { - global x - puts $s bye - close $s - set x ok - } - set server [socket -server accept -myaddr 127.0.0.1 0] - set port [lindex [fconfigure $server -sockname] 2] - } -body { - set client [socket -async localhost $port] - set after [after $latency {set x [fconfigure $client -error]}] - vwait x - set x - } -cleanup { - after cancel $after - close $server - close $client - unset x - } -result ok -test socket-14.0.1 {[socket -async] when server only listens on IPv6} \ - -constraints {socket supported_inet6 localhost_v6} \ - -setup { - proc accept {s a p} { - global x - puts $s bye - close $s - set x ok - } - set server [socket -server accept -myaddr ::1 0] - set port [lindex [fconfigure $server -sockname] 2] - } -body { - set client [socket -async localhost $port] - set after [after $latency {set x [fconfigure $client -error]}] - vwait x - set x - } -cleanup { - after cancel $after - close $server - close $client - unset x - } -result ok -test socket-14.1 {[socket -async] fileevent while still connecting} \ - -constraints {socket} \ - -setup { - proc accept {s a p} { - global x - puts $s bye - close $s - lappend x ok - } - set server [socket -server accept -myaddr localhost 0] - set port [lindex [fconfigure $server -sockname] 2] - set x "" - } -body { - set client [socket -async localhost $port] - fileevent $client writable { - lappend x [fconfigure $client -error] - fileevent $client writable {} - } - set after [after $latency {lappend x timeout}] - while {[llength $x] < 2 && "timeout" ni $x} { - vwait x - } - lsort $x; # we only want to see both events, the order doesn't matter - } -cleanup { - after cancel $after - close $server - close $client - unset x - } -result {{} ok} -test socket-14.2 {[socket -async] fileevent connection refused} \ - -constraints {socket} \ - -body { - set client [socket -async localhost [randport]] - fileevent $client writable {set x ok} - set after [after $latency {set x timeout}] - vwait x - after cancel $after - lappend x [fconfigure $client -error] - } -cleanup { - after cancel $after - close $client - unset x after client - } -result {ok {connection refused}} -test socket-14.3 {[socket -async] when server only listens on IPv6} \ - -constraints {socket supported_inet6 localhost_v6} \ - -setup { - proc accept {s a p} { - global x - puts $s bye - close $s - set x ok - } - set server [socket -server accept -myaddr ::1 0] - set port [lindex [fconfigure $server -sockname] 2] - } -body { - set client [socket -async localhost $port] - set after [after $latency {set x [fconfigure $client -error]}] - vwait x - set x - } -cleanup { - after cancel $after - close $server - close $client - unset x - } -result ok -test socket-14.4 {[socket -async] and both, readdable and writable fileevents} \ - -constraints {socket} \ - -setup { - proc accept {s a p} { - puts $s bye - close $s - } - set server [socket -server accept -myaddr localhost 0] - set port [lindex [fconfigure $server -sockname] 2] - set x "" - } -body { - set client [socket -async localhost $port] - fileevent $client writable { - lappend x [fconfigure $client -error] - fileevent $client writable {} - } - fileevent $client readable {lappend x [gets $client]} - set after [after $latency {lappend x timeout}] - while {[llength $x] < 2 && "timeout" ni $x} { - vwait x - } - lsort $x - } -cleanup { - after cancel $after - close $client - close $server - unset x - } -result {{} bye} +test socket-14.0.0 {[socket -async] when server only listens on IPv4} -setup { + proc accept {s a p} { + global x + puts $s bye + close $s + set x ok + } + set server [socket -server accept -myaddr 127.0.0.1 0] + set port [lindex [fconfigure $server -sockname] 2] +} -constraints {socket supported_inet localhost_v4} -body { + set client [socket -async localhost $port] + set after [after $latency {set x [fconfigure $client -error]}] + vwait x + set x +} -cleanup { + catch {after cancel $after} + catch {close $server} + catch {close $client} + unset -nocomplain x +} -result ok +test socket-14.0.1 {[socket -async] when server only listens on IPv6} -setup { + proc accept {s a p} { + global x + puts $s bye + close $s + set x ok + } + set server [socket -server accept -myaddr ::1 0] + set port [lindex [fconfigure $server -sockname] 2] +} -constraints {socket supported_inet6 localhost_v6} -body { + set client [socket -async localhost $port] + set after [after $latency {set x [fconfigure $client -error]}] + vwait x + set x +} -cleanup { + catch {after cancel $after} + catch {close $server} + catch {close $client} + unset -nocomplain x +} -result ok +test socket-14.1 {[socket -async] fileevent while still connecting} -setup { + proc accept {s a p} { + global x + puts $s bye + close $s + lappend x ok + } + set server [socket -server accept -myaddr localhost 0] + set port [lindex [fconfigure $server -sockname] 2] + set x "" +} -constraints socket -body { + set client [socket -async localhost $port] + fileevent $client writable { + lappend x [fconfigure $client -error] + fileevent $client writable {} + } + set after [after $latency {lappend x timeout}] + while {[llength $x] < 2 && "timeout" ni $x} { + vwait x + } + lsort $x; # we only want to see both events, the order doesn't matter +} -cleanup { + catch {after cancel $after} + catch {close $server} + catch {close $client} + unset -nocomplain x +} -result {{} ok} +test socket-14.2 {[socket -async] fileevent connection refused} -setup { + set after [after $latency set x timeout] +} -body { + set client [socket -async localhost [randport]] + fileevent $client writable {set x ok} + vwait x + lappend x [fconfigure $client -error] +} -constraints socket -cleanup { + catch {after cancel $after} + catch {close $client} + unset -nocomplain x after client +} -result {ok {connection refused}} +test socket-14.3 {[socket -async] when server only listens on IPv6} -setup { + proc accept {s a p} { + global x + puts $s bye + close $s + set x ok + } + set server [socket -server accept -myaddr ::1 0] + set port [lindex [fconfigure $server -sockname] 2] +} -constraints {socket supported_inet6 localhost_v6} -body { + set client [socket -async localhost $port] + set after [after $latency {set x [fconfigure $client -error]}] + vwait x + set x +} -cleanup { + catch {after cancel $after} + catch {close $server} + catch {close $client} + unset -nocomplain x +} -result ok +test socket-14.4 {[socket -async] and both, readdable and writable fileevents} -setup { + proc accept {s a p} { + puts $s bye + close $s + } + set server [socket -server accept -myaddr localhost 0] + set port [lindex [fconfigure $server -sockname] 2] + set x "" +} -constraints socket -body { + set client [socket -async localhost $port] + fileevent $client writable { + lappend x [fconfigure $client -error] + fileevent $client writable {} + } + fileevent $client readable {lappend x [gets $client]} + set after [after $latency {lappend x timeout}] + while {[llength $x] < 2 && "timeout" ni $x} { + vwait x + } + lsort $x +} -cleanup { + catch {after cancel $after} + catch {close $client} + catch {close $server} + unset -nocomplain x +} -result {{} bye} # FIXME: we should also have an IPv6 counterpart of this -test socket-14.5 {[socket -async] which fails before any connect() can be made} \ - -constraints {socket supported_inet} \ - -body { - # address from rfc5737 - socket -async -myaddr 192.0.2.42 127.0.0.1 [randport] - } \ - -returnCodes 1 \ +test socket-14.5 {[socket -async] which fails before any connect() can be made} -body { + # address from rfc5737 + socket -async -myaddr 192.0.2.42 127.0.0.1 [randport] +} -constraints {socket supported_inet notOSX} -returnCodes 1 \ -result {couldn't open socket: cannot assign requested address} -test socket-14.6.0 {[socket -async] with no event loop and server listening on IPv4} \ - -constraints {socket supported_inet localhost_v4} \ - -setup { - proc accept {s a p} { - global x - puts $s bye - close $s - set x ok - } - set server [socket -server accept -myaddr 127.0.0.1 0] - set port [lindex [fconfigure $server -sockname] 2] - set x "" - } \ - -body { - set client [socket -async localhost $port] - for {set i 0} {$i < 50} {incr i } { - update - if {$x ne ""} { - lappend x [gets $client] - break - } - after 100 - } - set x - } \ - -cleanup { - close $server - close $client - unset x - } \ - -result {ok bye} -test socket-14.6.1 {[socket -async] with no event loop and server listening on IPv6} \ - -constraints {socket supported_inet6 localhost_v6} \ - -setup { - proc accept {s a p} { - global x - puts $s bye - close $s - set x ok - } - set server [socket -server accept -myaddr ::1 0] - set port [lindex [fconfigure $server -sockname] 2] - set x "" - } \ - -body { - set client [socket -async localhost $port] - for {set i 0} {$i < 50} {incr i } { - update - if {$x ne ""} { - lappend x [gets $client] - break - } - after 100 - } - set x - } \ - -cleanup { - close $server - close $client - unset x - } \ - -result {ok bye} -test socket-14.7.0 {pending [socket -async] and blocking [gets], server is IPv4} \ - -constraints {socket supported_inet localhost_v4} \ - -setup { - makeFile { - fileevent stdin readable exit - set server [socket -server accept -myaddr 127.0.0.1 0] - proc accept {s h p} {puts $s ok; close $s; set ::x 1} - puts [lindex [fconfigure $server -sockname] 2] - flush stdout - vwait x - } script - set fd [open |[list [interpreter] script] RDWR] - set port [gets $fd] - } -body { - set sock [socket -async localhost $port] - list [fconfigure $sock -error] [gets $sock] [fconfigure $sock -error] - } -cleanup { - close $fd - close $sock - removeFile script - } -result {{} ok {}} -test socket-14.7.1 {pending [socket -async] and blocking [gets], server is IPv6} \ - -constraints {socket supported_inet6 localhost_v6} \ - -setup { - makeFile { - fileevent stdin readable exit - set server [socket -server accept -myaddr ::1 0] - proc accept {s h p} {puts $s ok; close $s; set ::x 1} - puts [lindex [fconfigure $server -sockname] 2] - flush stdout - vwait x - } script - set fd [open |[list [interpreter] script] RDWR] - set port [gets $fd] - } -body { - set sock [socket -async localhost $port] - list [fconfigure $sock -error] [gets $sock] [fconfigure $sock -error] - } -cleanup { - close $fd - close $sock - removeFile script - } -result {{} ok {}} -test socket-14.7.2 {pending [socket -async] and blocking [gets], no listener} \ - -constraints {socket} \ - -body { - set sock [socket -async localhost [randport]] - catch {gets $sock} x - list $x [fconfigure $sock -error] [fconfigure $sock -error] - } -cleanup { - close $sock - } -match glob -result {{error reading "sock*": socket is not connected} {connection refused} {}} -test socket-14.8.0 {pending [socket -async] and nonblocking [gets], server is IPv4} \ - -constraints {socket supported_inet localhost_v4} \ - -setup { - makeFile { - fileevent stdin readable exit - set server [socket -server accept -myaddr 127.0.0.1 0] - proc accept {s h p} {puts $s ok; close $s; set ::x 1} - puts [lindex [fconfigure $server -sockname] 2] - flush stdout - vwait x - } script - set fd [open |[list [interpreter] script] RDWR] - set port [gets $fd] - } -body { - set sock [socket -async localhost $port] - fconfigure $sock -blocking 0 - for {set i 0} {$i < 50} {incr i } { - if {[catch {gets $sock} x] || $x ne "" || ![fblocked $sock]} break - after 200 - } - set x - } -cleanup { - close $fd - close $sock - removeFile script - } -result {ok} -test socket-14.8.1 {pending [socket -async] and nonblocking [gets], server is IPv6} \ - -constraints {socket supported_inet6 localhost_v6} \ - -setup { - makeFile { - fileevent stdin readable exit - set server [socket -server accept -myaddr ::1 0] - proc accept {s h p} {puts $s ok; close $s; set ::x 1} - puts [lindex [fconfigure $server -sockname] 2] - flush stdout - vwait x - } script - set fd [open |[list [interpreter] script] RDWR] - set port [gets $fd] - } -body { - set sock [socket -async localhost $port] - fconfigure $sock -blocking 0 - for {set i 0} {$i < 50} {incr i } { - if {[catch {gets $sock} x] || $x ne "" || ![fblocked $sock]} break - after 200 - } - set x - } -cleanup { - close $fd - close $sock - removeFile script - } -result {ok} -test socket-14.8.2 {pending [socket -async] and nonblocking [gets], no listener} \ - -constraints {socket} \ - -body { - set sock [socket -async localhost [randport]] - fconfigure $sock -blocking 0 - for {set i 0} {$i < 50} {incr i } { - if {[catch {gets $sock} x] || $x ne "" || ![fblocked $sock]} break - after 200 - } - list $x [fconfigure $sock -error] [fconfigure $sock -error] - } -cleanup { - close $sock - } -match glob -result {{error reading "sock*": socket is not connected} {connection refused} {}} -test socket-14.9.0 {pending [socket -async] and blocking [puts], server is IPv4} \ - -constraints {socket supported_inet localhost_v4} \ - -setup { - makeFile { - fileevent stdin readable exit - set server [socket -server accept -myaddr 127.0.0.1 0] - proc accept {s h p} {set ::x $s} - puts [lindex [fconfigure $server -sockname] 2] - flush stdout - vwait x - puts [gets $x] - } script - set fd [open |[list [interpreter] script] RDWR] - set port [gets $fd] - } -body { - set sock [socket -async localhost $port] - puts $sock ok - flush $sock - list [fconfigure $sock -error] [gets $fd] - } -cleanup { - close $fd - close $sock - removeFile script - } -result {{} ok} -test socket-14.9.1 {pending [socket -async] and blocking [puts], server is IPv6} \ - -constraints {socket supported_inet6 localhost_v6} \ - -setup { - makeFile { - fileevent stdin readable exit - set server [socket -server accept -myaddr ::1 0] - proc accept {s h p} {set ::x $s} - puts [lindex [fconfigure $server -sockname] 2] - flush stdout - vwait x - puts [gets $x] - } script - set fd [open |[list [interpreter] script] RDWR] - set port [gets $fd] - } -body { - set sock [socket -async localhost $port] - puts $sock ok - flush $sock - list [fconfigure $sock -error] [gets $fd] - } -cleanup { - close $fd - close $sock - removeFile script - } -result {{} ok} -test socket-14.10.0 {pending [socket -async] and nonblocking [puts], server is IPv4} \ - -constraints {socket supported_inet localhost_v4} \ - -setup { - makeFile { - fileevent stdin readable exit - set server [socket -server accept -myaddr 127.0.0.1 0] - proc accept {s h p} {set ::x $s} - puts [lindex [fconfigure $server -sockname] 2] - flush stdout - vwait x - puts [gets $x] - } script - set fd [open |[list [interpreter] script] RDWR] - set port [gets $fd] - } -body { - set sock [socket -async localhost $port] - fconfigure $sock -blocking 0 - puts $sock ok - flush $sock - fileevent $fd readable {set x 1} - vwait x - list [fconfigure $sock -error] [gets $fd] - } -cleanup { - close $fd - close $sock - removeFile script - } -result {{} ok} -test socket-14.10.1 {pending [socket -async] and nonblocking [puts], server is IPv6} \ - -constraints {socket supported_inet6 localhost_v6} \ - -setup { - makeFile { - fileevent stdin readable exit - set server [socket -server accept -myaddr ::1 0] - proc accept {s h p} {set ::x $s} - puts [lindex [fconfigure $server -sockname] 2] - flush stdout - vwait x - puts [gets $x] - } script - set fd [open |[list [interpreter] script] RDWR] - set port [gets $fd] - } -body { - set sock [socket -async localhost $port] - fconfigure $sock -blocking 0 - puts $sock ok - flush $sock - fileevent $fd readable {set x 1} - vwait x - list [fconfigure $sock -error] [gets $fd] - } -cleanup { - close $fd - close $sock - removeFile script - } -result {{} ok} -test socket-14.11.0 {pending [socket -async] and nonblocking [puts], no listener, no flush} \ - -constraints {socket} \ - -body { - set sock [socket -async localhost [randport]] - fconfigure $sock -blocking 0 - puts $sock ok - fileevent $sock writable {set x 1} - vwait x - close $sock - } -cleanup { - catch {close $sock} - unset x - } -result {socket is not connected} -returnCodes 1 -test socket-14.11.1 {pending [socket -async] and nonblocking [puts], no listener, flush} \ - -constraints {socket nonPortable} \ - -body { - set sock [socket -async localhost [randport]] - fconfigure $sock -blocking 0 - puts $sock ok - flush $sock - fileevent $sock writable {set x 1} - vwait x - close $sock - } -cleanup { - catch {close $sock} - catch {unset x} - } -result {socket is not connected} -returnCodes 1 -test socket-14.12 {[socket -async] background progress triggered by [fconfigure -error]} \ - -constraints {socket} \ - -body { - set s [socket -async localhost [randport]] - for {set i 0} {$i < 50} {incr i} { - set x [fconfigure $s -error] - if {$x != ""} break - after 200 - } - set x - } -cleanup { - close $s - unset x s - } -result {connection refused} - -test socket-14.13 {testing writable event when quick failure} \ - -constraints {socket win supported_inet} \ - -body { +test socket-14.6.0 {[socket -async] with no event loop and server listening on IPv4} -setup { + proc accept {s a p} { + global x + puts $s bye + close $s + set x ok + } + set server [socket -server accept -myaddr 127.0.0.1 0] + set port [lindex [fconfigure $server -sockname] 2] + set x "" +} -constraints {socket supported_inet localhost_v4} -body { + set client [socket -async localhost $port] + for {set i 0} {$i < 50} {incr i } { + update + if {$x ne ""} { + lappend x [gets $client] + break + } + after 100 + } + set x +} -cleanup { + catch {close $server} + catch {close $client} + unset -nocomplain x +} -result {ok bye} +test socket-14.6.1 {[socket -async] with no event loop and server listening on IPv6} -setup { + proc accept {s a p} { + global x + puts $s bye + close $s + set x ok + } + set server [socket -server accept -myaddr ::1 0] + set port [lindex [fconfigure $server -sockname] 2] + set x "" +} -constraints {socket supported_inet6 localhost_v6} -body { + set client [socket -async localhost $port] + for {set i 0} {$i < 50} {incr i } { + update + if {$x ne ""} { + lappend x [gets $client] + break + } + after 100 + } + set x +} -cleanup { + catch {close $server} + catch {close $client} + unset -nocomplain x +} -result {ok bye} +test socket-14.7.0 {pending [socket -async] and blocking [gets], server is IPv4} -setup { + makeFile { + fileevent stdin readable exit + set server [socket -server accept -myaddr 127.0.0.1 0] + proc accept {s h p} {puts $s ok; close $s; set ::x 1} + puts [lindex [fconfigure $server -sockname] 2] + flush stdout + vwait x + } script + set fd [open |[list [interpreter] script] RDWR] + set port [gets $fd] +} -constraints {socket supported_inet localhost_v4 notOSX} -body { + set sock [socket -async localhost $port] + list [fconfigure $sock -error] [gets $sock] [fconfigure $sock -error] +} -cleanup { + catch {close $fd} + catch {close $sock} + removeFile script +} -result {{} ok {}} +test socket-14.7.1 {pending [socket -async] and blocking [gets], server is IPv6} -setup { + makeFile { + fileevent stdin readable exit + set server [socket -server accept -myaddr ::1 0] + proc accept {s h p} {puts $s ok; close $s; set ::x 1} + puts [lindex [fconfigure $server -sockname] 2] + flush stdout + vwait x + } script + set fd [open |[list [interpreter] script] RDWR] + set port [gets $fd] +} -constraints {socket supported_inet6 localhost_v6 notOSX} -body { + set sock [socket -async localhost $port] + list [fconfigure $sock -error] [gets $sock] [fconfigure $sock -error] +} -cleanup { + catch {close $fd} + catch {close $sock} + removeFile script +} -result {{} ok {}} +test socket-14.7.2 {pending [socket -async] and blocking [gets], no listener} -setup { + set sock [socket -server error 0] + set unusedPort [lindex [fconfigure $sock -sockname] 2] + close $sock +} -body { + set sock [socket -async localhost $unusedPort] + catch {gets $sock} x + list $x [fconfigure $sock -error] [fconfigure $sock -error] +} -constraints {socket notOSX} -cleanup { + catch {close $sock} +} -match glob -result {{error reading "sock*": socket is not connected} {connection refused} {}} +test socket-14.8.0 {pending [socket -async] and nonblocking [gets], server is IPv4} -setup { + makeFile { + fileevent stdin readable exit + set server [socket -server accept -myaddr 127.0.0.1 0] + proc accept {s h p} {puts $s ok; close $s; set ::x 1} + puts [lindex [fconfigure $server -sockname] 2] + flush stdout + vwait x + } script + set fd [open |[list [interpreter] script] RDWR] + set port [gets $fd] +} -constraints {socket supported_inet localhost_v4} -body { + set sock [socket -async localhost $port] + fconfigure $sock -blocking 0 + for {set i 0} {$i < 50} {incr i } { + if {[catch {gets $sock} x] || $x ne "" || ![fblocked $sock]} break + after 200 + } + set x +} -cleanup { + catch {close $fd} + catch {close $sock} + removeFile script +} -result {ok} +test socket-14.8.1 {pending [socket -async] and nonblocking [gets], server is IPv6} -setup { + makeFile { + fileevent stdin readable exit + set server [socket -server accept -myaddr ::1 0] + proc accept {s h p} {puts $s ok; close $s; set ::x 1} + puts [lindex [fconfigure $server -sockname] 2] + flush stdout + vwait x + } script + set fd [open |[list [interpreter] script] RDWR] + set port [gets $fd] +} -constraints {socket supported_inet6 localhost_v6} -body { + set sock [socket -async localhost $port] + fconfigure $sock -blocking 0 + for {set i 0} {$i < 50} {incr i } { + if {[catch {gets $sock} x] || $x ne "" || ![fblocked $sock]} break + after 200 + } + set x +} -cleanup { + catch {close $fd} + catch {close $sock} + removeFile script +} -result {ok} +test socket-14.8.2 {pending [socket -async] and nonblocking [gets], no listener} -body { + set sock [socket -async localhost [randport]] + fconfigure $sock -blocking 0 + for {set i 0} {$i < 50} {incr i } { + if {[catch {gets $sock} x] || $x ne "" || ![fblocked $sock]} break + after 200 + } + list $x [fconfigure $sock -error] [fconfigure $sock -error] +} -constraints socket -cleanup { + catch {close $sock} +} -match glob -result {{error reading "sock*": socket is not connected} {connection refused} {}} +test socket-14.9.0 {pending [socket -async] and blocking [puts], server is IPv4} -setup { + makeFile { + fileevent stdin readable exit + after 10000 exit + set server [socket -server accept -myaddr 127.0.0.1 0] + proc accept {s h p} {set ::x $s} + puts [lindex [fconfigure $server -sockname] 2] + flush stdout + vwait x + puts [gets $x] + } script + set fd [open |[list [interpreter] script] RDWR] + set port [gets $fd] +} -constraints {socket supported_inet localhost_v4 notOSX} -body { + set sock [socket -async localhost $port] + puts $sock ok + flush $sock + list [fconfigure $sock -error] [gets $fd] +} -cleanup { + catch {close $fd} + catch {close $sock} + removeFile script +} -result {{} ok} +test socket-14.9.1 {pending [socket -async] and blocking [puts], server is IPv6} -setup { + makeFile { + fileevent stdin readable exit + after 10000 exit + set server [socket -server accept -myaddr ::1 0] + proc accept {s h p} {set ::x $s} + puts [lindex [fconfigure $server -sockname] 2] + flush stdout + vwait x + puts [gets $x] + } script + set fd [open |[list [interpreter] script] RDWR] + set port [gets $fd] +} -constraints {socket supported_inet6 localhost_v6 notOSX} -body { + set sock [socket -async localhost $port] + puts $sock ok + flush $sock + list [fconfigure $sock -error] [gets $fd] +} -cleanup { + catch {close $fd} + catch {close $sock} + removeFile script +} -result {{} ok} +test socket-14.10.0 {pending [socket -async] and nonblocking [puts], server is IPv4} -setup { + makeFile { + fileevent stdin readable exit + set server [socket -server accept -myaddr 127.0.0.1 0] + proc accept {s h p} {set ::x $s} + puts [lindex [fconfigure $server -sockname] 2] + flush stdout + vwait x + puts [gets $x] + } script + set fd [open |[list [interpreter] script] RDWR] + set port [gets $fd] + set after [after $latency set x timeout] +} -constraints {socket supported_inet localhost_v4} -body { + set sock [socket -async localhost $port] + fconfigure $sock -blocking 0 + puts $sock ok + flush $sock + fileevent $fd readable {set x 1} + vwait x + list [fconfigure $sock -error] [gets $fd] +} -cleanup { + after cancel $after + catch {close $fd} + catch {close $sock} + removeFile script +} -result {{} ok} +test socket-14.10.1 {pending [socket -async] and nonblocking [puts], server is IPv6} -setup { + makeFile { + fileevent stdin readable exit + set server [socket -server accept -myaddr ::1 0] + proc accept {s h p} {set ::x $s} + puts [lindex [fconfigure $server -sockname] 2] + flush stdout + vwait x + puts [gets $x] + } script + set fd [open |[list [interpreter] script] RDWR] + set port [gets $fd] + set after [after $latency set x timeout] +} -constraints {socket supported_inet6 localhost_v6} -body { + set sock [socket -async localhost $port] + fconfigure $sock -blocking 0 + puts $sock ok + flush $sock + fileevent $fd readable {set x 1} + vwait x + list [fconfigure $sock -error] [gets $fd] +} -cleanup { + after cancel $after + catch {close $fd} + catch {close $sock} + removeFile script +} -result {{} ok} +test socket-14.11.0 {pending [socket -async] and nonblocking [puts], no listener, no flush} -setup { + set after [after $latency set x timeout] +} -body { + set sock [socket -async localhost [randport]] + fconfigure $sock -blocking 0 + puts $sock ok + fileevent $sock writable {set x 1} + vwait x + close $sock +} -constraints socket -cleanup { + after cancel $after + catch {close $sock} + unset -nocomplain x +} -result {socket is not connected} -returnCodes 1 +test socket-14.11.1 {pending [socket -async] and nonblocking [puts], no listener, flush} -setup { + set after [after $latency set x timeout] +} -body { + set sock [socket -async localhost [randport]] + fconfigure $sock -blocking 0 + puts $sock ok + flush $sock + fileevent $sock writable {set x 1} + vwait x + close $sock +} -constraints {socket nonPortable} -cleanup { + after cancel $timeout + catch {close $sock} + unset -nocomplain x +} -result {socket is not connected} -returnCodes 1 +test socket-14.12 {[socket -async] background progress triggered by [fconfigure -error]} -body { + set s [socket -async localhost [randport]] + for {set i 0} {$i < 50} {incr i} { + set x [fconfigure $s -error] + if {$x != ""} break + after 200 + } + set x +} -constraints socket -cleanup { + catch {close $s} + unset -nocomplain x s +} -result {connection refused} +test socket-14.13 {testing writable event when quick failure} -body { # Test for bug 336441ed59 where a quick background fail was ignored - + # # Test only for windows as socket -async 255.255.255.255 fails # directly on unix - + # # The following connect should fail very quickly - set a1 [after 2000 {set x timeout}] + set a1 [after $latency {set x timeout}] set s [socket -async 255.255.255.255 43434] fileevent $s writable {set x writable} vwait x set x -} -cleanup { +} -constraints {socket win supported_inet} -cleanup { catch {close $s} after cancel $a1 } -result writable - -test socket-14.14 {testing fileevent readable on failed async socket connect} \ - -constraints {socket} -body { +test socket-14.14 {testing fileevent readable on failed async socket connect} -body { # Test for bug 581937ab1e - - set a1 [after 5000 {set x timeout}] + set a1 [after $latency {set x timeout}] # This connect should fail set s [socket -async localhost [randport]] fileevent $s readable {set x readable} vwait x set x -} -cleanup { +} -constraints socket -cleanup { catch {close $s} after cancel $a1 } -result readable - -test socket-14.15 {blocking read on async socket should not trigger event handlers} \ - -constraints socket -body { - set s [socket -async localhost [randport]] - set x ok - fileevent $s writable {set x fail} - catch {read $s} +test socket-14.15 {blocking read on async socket should not trigger event handlers} -setup { + set subprocess [open "|[list [interpreter]]" r+] + fconfigure $subprocess -blocking 0 -buffering none +} -constraints socket -body { + puts $subprocess { + set s [socket -async localhost [randport]] + set x ok + fileevent $s writable {set x fail} + catch {read $s} close $s - set x - } -result ok - + puts $x + exit + } + set after [after $latency set x timeout] + fileevent $subprocess readable [list gets $subprocess x] + vwait x + return $x +} -cleanup { + catch {after cancel $after} + if {![testConstraint win]} { + catch {exec kill [pid $subprocess]} + } + catch {close $subprocess} + unset -nocomplain x +} -result ok # v4 and v6 is required to prevent that the async connect does not terminate # before the fconfigure command. There is always an additional ip to try. -test socket-14.16 {empty -peername while [socket -async] connecting} \ - -constraints {socket localhost_v4 localhost_v6} \ - -body { - set client [socket -async localhost [randport]] - fconfigure $client -peername - } -cleanup { - catch {close $client} - } -result {} - +test socket-14.16 {empty -peername while [socket -async] connecting} -body { + set client [socket -async localhost [randport]] + fconfigure $client -peername +} -constraints {socket localhost_v4 localhost_v6 notOSX} -cleanup { + catch {close $client} +} -result {} # v4 and v6 is required to prevent that the async connect does not terminate # before the fconfigure command. There is always an additional ip to try. -test socket-14.17 {empty -sockname while [socket -async] connecting} \ - -constraints {socket localhost_v4 localhost_v6} \ - -body { - set client [socket -async localhost [randport]] - fconfigure $client -sockname - } -cleanup { - catch {close $client} - } -result {} - +test socket-14.17 {empty -sockname while [socket -async] connecting} -body { + set client [socket -async localhost [randport]] + fconfigure $client -sockname +} -constraints {socket localhost_v4 localhost_v6 notOSX} -cleanup { + catch {close $client} +} -result {} # test for bug c6ed4acfd8: running async socket connect with other connect # established will block tcl as it goes in an infinite loop in vwait -test socket-14.18 {bug c6ed4acfd8: running async socket connect made other connect block} \ - -constraints {socket} \ - -body { - proc accept {channel address port} {} - set port [randport] - set ssock [socket -server accept $port] - set csock1 [socket -async localhost [randport]] - set csock2 [socket localhost $port] - after 1000 {set done ok} - vwait done -} -cleanup { - catch {close $ssock} - catch {close $csock1} - catch {close $csock2} - } -result {} +test socket-14.18 {bug c6ed4acfd8: running async socket connect made other connect block} -body { + proc accept {channel address port} {} + set port [randport] + set ssock [socket -server accept $port] + set csock1 [socket -async localhost [randport]] + set csock2 [socket localhost $port] + after 1000 {set done ok} + vwait done +} -constraints {socket notOSX} -cleanup { + catch {close $ssock} + catch {close $csock1} + catch {close $csock2} +} -result {} set num 0 @@ -2385,8 +2353,7 @@ set resulterr { } foreach {servip sc} $x { foreach {cliip cc} $x { - set constraints socket - lappend constraints $sc $cc + set constraints [list socket $sc $cc] set result $resulterr switch -- [lsort -unique [list $servip $cliip]] { localhost - 127.0.0.1 - ::1 { @@ -2403,17 +2370,16 @@ foreach {servip sc} $x { } } } - test socket-15.1.$num "Connect to $servip from $cliip" \ - -constraints $constraints -setup { - set server [socket -server accept -myaddr $servip 0] - proc accept {s h p} { close $s } - set port [lindex [fconfigure $server -sockname] 2] - } -body { - set s [socket $cliip $port] - } -cleanup { - close $server - catch {close $s} - } {*}$result + test socket-15.1.$num "Connect to $servip from $cliip" -setup { + set server [socket -server accept -myaddr $servip 0] + proc accept {s h p} { close $s } + set port [lindex [fconfigure $server -sockname] 2] + } -constraints $constraints -body { + set s [socket $cliip $port] + } -cleanup { + close $server + catch {close $s} + } {*}$result incr num } } -- cgit v0.12 From b16a1198d956d1b2e69a3c5396a0a51fa6ce4cc3 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 14 Nov 2018 07:39:45 +0000 Subject: Workaround for crypt.h, when used in combination with older zlib library. Should make Travis build work again --- compat/zlib/contrib/minizip/crypt.h | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/compat/zlib/contrib/minizip/crypt.h b/compat/zlib/contrib/minizip/crypt.h index 1e9e820..c422c26 100644 --- a/compat/zlib/contrib/minizip/crypt.h +++ b/compat/zlib/contrib/minizip/crypt.h @@ -29,6 +29,12 @@ #define CRC32(c, b) ((*(pcrc_32_tab+(((int)(c) ^ (b)) & 0xff))) ^ ((c) >> 8)) +#ifdef Z_U4 + typedef Z_U4 z_crc_t; +#else + typedef unsigned long z_crc_t; +#endif + /*********************************************************************** * Return the next byte in the pseudo-random sequence */ -- cgit v0.12 From 5e8ed94397dacbc7dd8fee69ea0aab5911d754f8 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 15 Nov 2018 08:05:23 +0000 Subject: Make Tcl_WinTCharToUtf/Tcl_WinUtfToTChar work (again) with TCL_UTF_MAX=6. No effect when TCL_UTF_MAX=3|4 --- generic/tclStubInit.c | 88 ++++++++++++++++++++++++++++++++++++++++++++++++ win/tclWin32Dll.c | 92 +++++++++++++++++++++++++++++++++++++++++++++++++-- 2 files changed, 178 insertions(+), 2 deletions(-) diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index cbf4084..f7b374c 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -188,11 +188,68 @@ Tcl_WinUtfToTChar( int len, Tcl_DString *dsPtr) { +#if TCL_UTF_MAX > 4 + Tcl_UniChar ch = 0; + wchar_t *w, *wString; + const char *p, *end; + int oldLength; +#endif + Tcl_DStringInit(dsPtr); if (!string) { return NULL; } +#if TCL_UTF_MAX > 4 + + if (len < 0) { + len = strlen(string); + } + + /* + * Unicode string length in Tcl_UniChars will be <= UTF-8 string length in + * bytes. + */ + + oldLength = Tcl_DStringLength(dsPtr); + + Tcl_DStringSetLength(dsPtr, + oldLength + (int) ((len + 1) * sizeof(wchar_t))); + wString = (wchar_t *) (Tcl_DStringValue(dsPtr) + oldLength); + + w = wString; + p = string; + end = string + len - 4; + while (p < end) { + p += TclUtfToUniChar(p, &ch); + if (ch > 0xFFFF) { + *w++ = (wchar_t) (0xD800 + ((ch -= 0x10000) >> 10)); + *w++ = (wchar_t) (0xDC00 | (ch & 0x3FF)); + } else { + *w++ = ch; + } + } + end += 4; + while (p < end) { + if (Tcl_UtfCharComplete(p, end-p)) { + p += TclUtfToUniChar(p, &ch); + } else { + ch = UCHAR(*p++); + } + if (ch > 0xFFFF) { + *w++ = (wchar_t) (0xD800 + ((ch -= 0x10000) >> 10)); + *w++ = (wchar_t) (0xDC00 | (ch & 0x3FF)); + } else { + *w++ = ch; + } + } + *w = '\0'; + Tcl_DStringSetLength(dsPtr, + oldLength + ((char *) w - (char *) wString)); + + return (char *)wString; +#else return (char *)Tcl_UtfToUniCharDString(string, len, dsPtr); +#endif } char * @@ -201,6 +258,12 @@ Tcl_WinTCharToUtf( int len, Tcl_DString *dsPtr) { +#if TCL_UTF_MAX > 4 + const wchar_t *w, *wEnd; + char *p, *result; + int oldLength, blen = 1; +#endif + Tcl_DStringInit(dsPtr); if (!string) { return NULL; @@ -210,7 +273,32 @@ Tcl_WinTCharToUtf( } else { len /= 2; } +#if TCL_UTF_MAX > 4 + oldLength = Tcl_DStringLength(dsPtr); + Tcl_DStringSetLength(dsPtr, oldLength + (len + 1) * 4); + result = Tcl_DStringValue(dsPtr) + oldLength; + + p = result; + wEnd = (wchar_t *)string + len; + for (w = (wchar_t *)string; w < wEnd; ) { + if (!blen && ((*w & 0xFC00) != 0xDC00)) { + /* Special case for handling upper surrogates. */ + p += Tcl_UniCharToUtf(-1, p); + } + blen = Tcl_UniCharToUtf(*w, p); + p += blen; + w++; + } + if (!blen) { + /* Special case for handling upper surrogates. */ + p += Tcl_UniCharToUtf(-1, p); + } + Tcl_DStringSetLength(dsPtr, oldLength + (p - result)); + + return result; +#else return Tcl_UniCharToUtfDString((Tcl_UniChar *)string, len, dsPtr); +#endif } #if defined(TCL_WIDE_INT_IS_LONG) diff --git a/win/tclWin32Dll.c b/win/tclWin32Dll.c index 6fc2401..3fb8796 100644 --- a/win/tclWin32Dll.c +++ b/win/tclWin32Dll.c @@ -547,11 +547,68 @@ Tcl_WinUtfToTChar( Tcl_DString *dsPtr) /* Uninitialized or free DString in which the * converted string is stored. */ { +#if TCL_UTF_MAX > 4 + Tcl_UniChar ch = 0; + TCHAR *w, *wString; + const char *p, *end; + int oldLength; +#endif + Tcl_DStringInit(dsPtr); if (!string) { return NULL; } +#if TCL_UTF_MAX > 4 + + if (len < 0) { + len = strlen(string); + } + + /* + * Unicode string length in Tcl_UniChars will be <= UTF-8 string length in + * bytes. + */ + + oldLength = Tcl_DStringLength(dsPtr); + + Tcl_DStringSetLength(dsPtr, + oldLength + (int) ((len + 1) * sizeof(TCHAR))); + wString = (TCHAR *) (Tcl_DStringValue(dsPtr) + oldLength); + + w = wString; + p = string; + end = string + len - 4; + while (p < end) { + p += TclUtfToUniChar(p, &ch); + if (ch > 0xFFFF) { + *w++ = (wchar_t) (0xD800 + ((ch -= 0x10000) >> 10)); + *w++ = (wchar_t) (0xDC00 | (ch & 0x3FF)); + } else { + *w++ = ch; + } + } + end += 4; + while (p < end) { + if (Tcl_UtfCharComplete(p, end-p)) { + p += TclUtfToUniChar(p, &ch); + } else { + ch = UCHAR(*p++); + } + if (ch > 0xFFFF) { + *w++ = (wchar_t) (0xD800 + ((ch -= 0x10000) >> 10)); + *w++ = (wchar_t) (0xDC00 | (ch & 0x3FF)); + } else { + *w++ = ch; + } + } + *w = '\0'; + Tcl_DStringSetLength(dsPtr, + oldLength + ((char *) w - (char *) wString)); + + return wString; +#else return Tcl_UtfToUniCharDString(string, len, dsPtr); +#endif } char * @@ -562,16 +619,47 @@ Tcl_WinTCharToUtf( Tcl_DString *dsPtr) /* Uninitialized or free DString in which the * converted string is stored. */ { +#if TCL_UTF_MAX > 4 + const TCHAR *w, *wEnd; + char *p, *result; + int oldLength, blen = 1; +#endif + Tcl_DStringInit(dsPtr); if (!string) { return NULL; } if (len < 0) { - len = wcslen(string); + len = wcslen((TCHAR *)string); } else { len /= 2; } - return Tcl_UniCharToUtfDString(string, len, dsPtr); +#if TCL_UTF_MAX > 4 + oldLength = Tcl_DStringLength(dsPtr); + Tcl_DStringSetLength(dsPtr, oldLength + (len + 1) * 4); + result = Tcl_DStringValue(dsPtr) + oldLength; + + p = result; + wEnd = (TCHAR *)string + len; + for (w = (TCHAR *)string; w < wEnd; ) { + if (!blen && ((*w & 0xFC00) != 0xDC00)) { + /* Special case for handling upper surrogates. */ + p += Tcl_UniCharToUtf(-1, p); + } + blen = Tcl_UniCharToUtf(*w, p); + p += blen; + w++; + } + if (!blen) { + /* Special case for handling upper surrogates. */ + p += Tcl_UniCharToUtf(-1, p); + } + Tcl_DStringSetLength(dsPtr, oldLength + (p - result)); + + return result; +#else + return Tcl_UniCharToUtfDString((Tcl_UniChar *)string, len, dsPtr); +#endif } /* -- cgit v0.12 From b3d56cb3645f93ae374badaca88dd2559e0c5421 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 15 Nov 2018 08:34:59 +0000 Subject: Another attempt to fix Travis build: making the build robust against older zlib.h header file --- generic/tclZipfs.c | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c index 428be15..4864a43 100644 --- a/generic/tclZipfs.c +++ b/generic/tclZipfs.c @@ -291,6 +291,11 @@ static const char pwrot[16] = { /* * Table to compute CRC32. */ +#ifdef Z_U4 + typedef Z_U4 z_crc_t; +#else + typedef unsigned long z_crc_t; +#endif static const z_crc_t crc32tab[256] = { 0x00000000, 0x77073096, 0xee0e612c, 0x990951ba, 0x076dc419, -- cgit v0.12 From e348eadefd9b0713d7a81cbda827a45b5b50271b Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 15 Nov 2018 10:23:31 +0000 Subject: Stop more crashes on Travis --- tests/httpcookie.test | 260 +++++++++++++++++++++++++++----------------------- 1 file changed, 138 insertions(+), 122 deletions(-) diff --git a/tests/httpcookie.test b/tests/httpcookie.test index d4acad9..8835791 100644 --- a/tests/httpcookie.test +++ b/tests/httpcookie.test @@ -12,44 +12,59 @@ package require tcltest 2 namespace import -force ::tcltest::* -testConstraint sqlite3 [expr {![catch { +testConstraint notOSXtravis [apply {{} { + upvar 1 env(TRAVIS_OSX_IMAGE) travis + return [expr {![info exists travis] || ![string match xcode* $travis]}] +}}] +testConstraint sqlite3 [expr {[testConstraint notOSXtravis] && ![catch { package require sqlite3 }]}] -testConstraint cookiejar [expr {![catch { - if {[testConstraint sqlite3]} { - package require cookiejar - } +testConstraint cookiejar [expr {[testConstraint sqlite3] && ![catch { + package require cookiejar }]}] -test http-cookiejar-1.1 {cookie storage: packaging} {sqlite3 cookiejar} { +set COOKIEJAR_VERSION 0.1 +test http-cookiejar-1.1 "cookie storage: packaging" {notOSXtravis sqlite3 cookiejar} { package require cookiejar -} 0.1 -test http-cookiejar-1.2 {cookie storage: packaging} {sqlite3 cookiejar} { +} $COOKIEJAR_VERSION +test http-cookiejar-1.2 "cookie storage: packaging" {notOSXtravis sqlite3 cookiejar} { package require cookiejar package require cookiejar -} 0.1 +} $COOKIEJAR_VERSION -test http-cookiejar-2.1 {cookie storage: basics} -constraints {sqlite3 cookiejar} -body { +test http-cookiejar-2.1 "cookie storage: basics" -constraints { + notOSXtravis sqlite3 cookiejar +} -returnCodes error -body { http::cookiejar -} -returnCodes error -result {wrong # args: should be "http::cookiejar method ?arg ...?"} -test http-cookiejar-2.2 {cookie storage: basics} -constraints {sqlite3 cookiejar} -body { +} -result {wrong # args: should be "http::cookiejar method ?arg ...?"} +test http-cookiejar-2.2 "cookie storage: basics" -constraints { + notOSXtravis sqlite3 cookiejar +} -returnCodes error -body { http::cookiejar ? -} -returnCodes error -result {unknown method "?": must be configure, create, destroy or new} -test http-cookiejar-2.3 {cookie storage: basics} {sqlite3 cookiejar} { +} -result {unknown method "?": must be configure, create, destroy or new} +test http-cookiejar-2.3 "cookie storage: basics" -constraints { + notOSXtravis sqlite3 cookiejar +} -body { http::cookiejar configure -} {-domainfile -domainlist -domainrefresh -loglevel -offline -purgeold -retain -vacuumtrigger} -test http-cookiejar-2.4 {cookie storage: basics} -constraints {sqlite3 cookiejar} -body { +} -result {-domainfile -domainlist -domainrefresh -loglevel -offline -purgeold -retain -vacuumtrigger} +test http-cookiejar-2.4 "cookie storage: basics" -constraints { + notOSXtravis sqlite3 cookiejar +} -returnCodes error -body { http::cookiejar configure a b c d e -} -returnCodes error -result {wrong # args: should be "http::cookiejar configure ?optionName? ?optionValue?"} -test http-cookiejar-2.5 {cookie storage: basics} -constraints {sqlite3 cookiejar} -body { +} -result {wrong # args: should be "http::cookiejar configure ?optionName? ?optionValue?"} +test http-cookiejar-2.5 "cookie storage: basics" -constraints { + notOSXtravis sqlite3 cookiejar +} -returnCodes error -body { http::cookiejar configure a -} -returnCodes error -result {bad option "a": must be -domainfile, -domainlist, -domainrefresh, -loglevel, -offline, -purgeold, -retain, or -vacuumtrigger} -test http-cookiejar-2.6 {cookie storage: basics} -constraints {sqlite3 cookiejar} -body { +} -result {bad option "a": must be -domainfile, -domainlist, -domainrefresh, -loglevel, -offline, -purgeold, -retain, or -vacuumtrigger} +test http-cookiejar-2.6 "cookie storage: basics" -constraints { + notOSXtravis sqlite3 cookiejar +} -returnCodes error -body { http::cookiejar configure -d -} -returnCodes error -result {ambiguous option "-d": must be -domainfile, -domainlist, -domainrefresh, -loglevel, -offline, -purgeold, -retain, or -vacuumtrigger} -test http-cookiejar-2.7 {cookie storage: basics} -setup { +} -result {ambiguous option "-d": must be -domainfile, -domainlist, -domainrefresh, -loglevel, -offline, -purgeold, -retain, or -vacuumtrigger} +test http-cookiejar-2.7 "cookie storage: basics" -setup { set old [http::cookiejar configure -loglevel] -} -constraints {sqlite3 cookiejar} -body { +} -constraints {notOSXtravis sqlite3 cookiejar} -body { list [http::cookiejar configure -loglevel] \ [http::cookiejar configure -loglevel debug] \ [http::cookiejar configure -loglevel] \ @@ -58,9 +73,9 @@ test http-cookiejar-2.7 {cookie storage: basics} -setup { } -cleanup { http::cookiejar configure -loglevel $old } -result {info debug debug error error} -test http-cookiejar-2.8 {cookie storage: basics} -setup { +test http-cookiejar-2.8 "cookie storage: basics" -setup { set old [http::cookiejar configure -loglevel] -} -constraints {sqlite3 cookiejar} -body { +} -constraints {notOSXtravis sqlite3 cookiejar} -body { list [http::cookiejar configure -loglevel] \ [http::cookiejar configure -loglevel d] \ [http::cookiejar configure -loglevel i] \ @@ -69,49 +84,49 @@ test http-cookiejar-2.8 {cookie storage: basics} -setup { } -cleanup { http::cookiejar configure -loglevel $old } -result {info debug info warn error} -test http-cookiejar-2.9 {cookie storage: basics} -constraints {sqlite3 cookiejar} -body { +test http-cookiejar-2.9 "cookie storage: basics" -body { http::cookiejar configure -off -} -match glob -result * -test http-cookiejar-2.10 {cookie storage: basics} -setup { +} -constraints {notOSXtravis sqlite3 cookiejar} -match glob -result * +test http-cookiejar-2.10 "cookie storage: basics" -setup { set oldval [http::cookiejar configure -offline] -} -constraints {sqlite3 cookiejar} -body { +} -constraints {notOSXtravis sqlite3 cookiejar} -body { http::cookiejar configure -offline true } -cleanup { catch {http::cookiejar configure -offline $oldval} } -result 1 -test http-cookiejar-2.11 {cookie storage: basics} -setup { +test http-cookiejar-2.11 "cookie storage: basics" -setup { set oldval [http::cookiejar configure -offline] -} -constraints {sqlite3 cookiejar} -body { +} -constraints {notOSXtravis sqlite3 cookiejar} -body { http::cookiejar configure -offline nonbool } -cleanup { catch {http::cookiejar configure -offline $oldval} } -returnCodes error -result {expected boolean value but got "nonbool"} -test http-cookiejar-2.12 {cookie storage: basics} -setup { +test http-cookiejar-2.12 "cookie storage: basics" -setup { set oldval [http::cookiejar configure -purgeold] -} -constraints {sqlite3 cookiejar} -body { +} -constraints {notOSXtravis sqlite3 cookiejar} -body { http::cookiejar configure -purge nonint } -cleanup { catch {http::cookiejar configure -purgeold $oldval} } -returnCodes error -result {expected positive integer but got "nonint"} -test http-cookiejar-2.13 {cookie storage: basics} -setup { +test http-cookiejar-2.13 "cookie storage: basics" -setup { set oldval [http::cookiejar configure -domainrefresh] -} -constraints {sqlite3 cookiejar} -body { +} -constraints {notOSXtravis sqlite3 cookiejar} -body { http::cookiejar configure -domainref nonint } -cleanup { catch {http::cookiejar configure -domainrefresh $oldval} } -returnCodes error -result {expected positive integer but got "nonint"} -test http-cookiejar-2.14 {cookie storage: basics} -setup { +test http-cookiejar-2.14 "cookie storage: basics" -setup { set oldval [http::cookiejar configure -domainrefresh] -} -constraints {sqlite3 cookiejar} -body { +} -constraints {notOSXtravis sqlite3 cookiejar} -body { http::cookiejar configure -domainref -42 } -cleanup { catch {http::cookiejar configure -domainrefresh $oldval} } -returnCodes error -result {expected positive integer but got "-42"} -test http-cookiejar-2.15 {cookie storage: basics} -setup { +test http-cookiejar-2.15 "cookie storage: basics" -setup { set oldval [http::cookiejar configure -domainrefresh] set result unset set tracer [http::cookiejar create tracer] -} -constraints {sqlite3 cookiejar} -body { +} -constraints {notOSXtravis sqlite3 cookiejar} -body { oo::objdefine $tracer method PostponeRefresh {} { set ::result set next @@ -123,114 +138,115 @@ test http-cookiejar-2.15 {cookie storage: basics} -setup { catch {http::cookiejar configure -domainrefresh $oldval} } -result set -test http-cookiejar-3.1 {cookie storage: class} {sqlite3 cookiejar} { +test http-cookiejar-3.1 "cookie storage: class" {notOSXtravis sqlite3 cookiejar} { info object isa object http::cookiejar } 1 -test http-cookiejar-3.2 {cookie storage: class} {sqlite3 cookiejar} { +test http-cookiejar-3.2 "cookie storage: class" {notOSXtravis sqlite3 cookiejar} { info object isa class http::cookiejar } 1 -test http-cookiejar-3.3 {cookie storage: class} {sqlite3 cookiejar} { +test http-cookiejar-3.3 "cookie storage: class" {notOSXtravis sqlite3 cookiejar} { lsort [info object methods http::cookiejar] } {configure} -test http-cookiejar-3.4 {cookie storage: class} {sqlite3 cookiejar} { +test http-cookiejar-3.4 "cookie storage: class" {notOSXtravis sqlite3 cookiejar} { lsort [info object methods http::cookiejar -all] } {configure create destroy new} -test http-cookiejar-3.5 {cookie storage: class} -setup { +test http-cookiejar-3.5 "cookie storage: class" -setup { catch {rename ::cookiejar ""} -} -constraints {sqlite3 cookiejar} -body { +} -constraints {notOSXtravis sqlite3 cookiejar} -body { namespace eval :: {http::cookiejar create cookiejar} } -cleanup { catch {rename ::cookiejar ""} } -result ::cookiejar -test http-cookiejar-3.6 {cookie storage: class} -setup { +test http-cookiejar-3.6 "cookie storage: class" -setup { catch {rename ::cookiejar ""} -} -constraints {sqlite3 cookiejar} -body { +} -constraints {notOSXtravis sqlite3 cookiejar} -body { list [http::cookiejar create ::cookiejar] [info commands ::cookiejar] \ [::cookiejar destroy] [info commands ::cookiejar] } -cleanup { catch {rename ::cookiejar ""} } -result {::cookiejar ::cookiejar {} {}} -test http-cookiejar-3.7 {cookie storage: class} -setup { +test http-cookiejar-3.7 "cookie storage: class" -setup { catch {rename ::cookiejar ""} -} -constraints {sqlite3 cookiejar} -body { +} -constraints {notOSXtravis sqlite3 cookiejar} -body { http::cookiejar create ::cookiejar foo bar } -returnCodes error -cleanup { catch {rename ::cookiejar ""} } -result {wrong # args: should be "http::cookiejar create ::cookiejar ?path?"} -test http-cookiejar-3.8 {cookie storage: class} -setup { +test http-cookiejar-3.8 "cookie storage: class" -setup { catch {rename ::cookiejar ""} set f [makeFile "" cookiejar] file delete $f -} -constraints {sqlite3 cookiejar} -body { - http::cookiejar create ::cookiejar $f +} -constraints {notOSXtravis sqlite3 cookiejar} -body { + list [file exists $f] [http::cookiejar create ::cookiejar $f] \ + [file exists $f] } -cleanup { catch {rename ::cookiejar ""} removeFile $f -} -result ::cookiejar -test http-cookiejar-3.9 {cookie storage: class} -setup { +} -result {0 ::cookiejar 1} +test http-cookiejar-3.9 "cookie storage: class" -setup { catch {rename ::cookiejar ""} set f [makeFile "bogus content for a database" cookiejar] -} -constraints {sqlite3 cookiejar} -body { +} -constraints {notOSXtravis sqlite3 cookiejar} -body { http::cookiejar create ::cookiejar $f } -returnCodes error -cleanup { catch {rename ::cookiejar ""} removeFile $f } -match glob -result * -test http-cookiejar-3.10 {cookie storage: class} -setup { +test http-cookiejar-3.10 "cookie storage: class" -setup { catch {rename ::cookiejar ""} set dir [makeDirectory cookiejar] -} -constraints {sqlite3 cookiejar} -body { +} -constraints {notOSXtravis sqlite3 cookiejar} -body { http::cookiejar create ::cookiejar $dir } -returnCodes error -cleanup { catch {rename ::cookiejar ""} removeDirectory $dir -} -result {unable to open database file} +} -match glob -result * -test http-cookiejar-4.1 {cookie storage: instance} -setup { +test http-cookiejar-4.1 "cookie storage: instance" -setup { http::cookiejar create ::cookiejar -} -constraints {sqlite3 cookiejar} -body { +} -constraints {notOSXtravis sqlite3 cookiejar} -body { cookiejar } -returnCodes error -cleanup { ::cookiejar destroy } -result {wrong # args: should be "cookiejar method ?arg ...?"} -test http-cookiejar-4.2 {cookie storage: instance} -setup { +test http-cookiejar-4.2 "cookie storage: instance" -setup { http::cookiejar create ::cookiejar -} -constraints {sqlite3 cookiejar} -body { +} -constraints {notOSXtravis sqlite3 cookiejar} -body { cookiejar ? } -returnCodes error -cleanup { ::cookiejar destroy } -result {unknown method "?": must be destroy, forceLoadDomainData, getCookies, lookup, policyAllow or storeCookie} -test http-cookiejar-4.3 {cookie storage: instance} -setup { +test http-cookiejar-4.3 "cookie storage: instance" -setup { http::cookiejar create ::cookiejar -} -constraints {sqlite3 cookiejar} -body { +} -constraints {notOSXtravis sqlite3 cookiejar} -body { lsort [info object methods cookiejar -all] } -cleanup { ::cookiejar destroy } -result {destroy forceLoadDomainData getCookies lookup policyAllow storeCookie} -test http-cookiejar-4.4 {cookie storage: instance} -setup { +test http-cookiejar-4.4 "cookie storage: instance" -setup { http::cookiejar create ::cookiejar -} -constraints {sqlite3 cookiejar} -body { +} -constraints {notOSXtravis sqlite3 cookiejar} -body { cookiejar getCookies } -returnCodes error -cleanup { ::cookiejar destroy } -result {wrong # args: should be "cookiejar getCookies proto host path"} -test http-cookiejar-4.5 {cookie storage} -setup { +test http-cookiejar-4.5 "cookie storage" -setup { http::cookiejar create ::cookiejar -} -constraints {sqlite3 cookiejar} -body { +} -constraints {notOSXtravis sqlite3 cookiejar} -body { cookiejar getCookies http www.example.com / } -cleanup { ::cookiejar destroy } -result {} -test http-cookiejar-4.6 {cookie storage: instance} -setup { +test http-cookiejar-4.6 "cookie storage: instance" -setup { http::cookiejar create ::cookiejar -} -constraints {sqlite3 cookiejar} -body { +} -constraints {notOSXtravis sqlite3 cookiejar} -body { cookiejar storeCookie } -returnCodes error -cleanup { ::cookiejar destroy } -result {wrong # args: should be "cookiejar storeCookie options"} -test http-cookiejar-4.7 {cookie storage: instance} -setup { +test http-cookiejar-4.7 "cookie storage: instance" -setup { http::cookiejar create ::cookiejar -} -constraints {sqlite3 cookiejar} -body { +} -constraints {notOSXtravis sqlite3 cookiejar} -body { cookiejar storeCookie { key foo value bar @@ -243,10 +259,10 @@ test http-cookiejar-4.7 {cookie storage: instance} -setup { } -cleanup { ::cookiejar destroy } -result {} -test http-cookiejar-4.8 {cookie storage: instance} -setup { +test http-cookiejar-4.8 "cookie storage: instance" -setup { http::cookiejar create ::cookiejar oo::objdefine ::cookiejar export Database -} -constraints {sqlite3 cookiejar} -body { +} -constraints {notOSXtravis sqlite3 cookiejar} -body { cookiejar storeCookie { key foo value bar @@ -261,10 +277,10 @@ test http-cookiejar-4.8 {cookie storage: instance} -setup { } -cleanup { ::cookiejar destroy } -result 1 -test http-cookiejar-4.9 {cookie storage: instance} -setup { +test http-cookiejar-4.9 "cookie storage: instance" -setup { http::cookiejar create ::cookiejar oo::objdefine ::cookiejar export Database -} -constraints {sqlite3 cookiejar} -body { +} -constraints {notOSXtravis sqlite3 cookiejar} -body { cookiejar storeCookie { key foo value bar @@ -279,9 +295,9 @@ test http-cookiejar-4.9 {cookie storage: instance} -setup { } -cleanup { ::cookiejar destroy } -result 0 -test http-cookiejar-4.10 {cookie storage: instance} -setup { +test http-cookiejar-4.10 "cookie storage: instance" -setup { http::cookiejar create ::cookiejar -} -constraints {sqlite3 cookiejar} -body { +} -constraints {notOSXtravis sqlite3 cookiejar} -body { cookiejar storeCookie [dict replace { key foo value bar @@ -294,10 +310,10 @@ test http-cookiejar-4.10 {cookie storage: instance} -setup { } -cleanup { ::cookiejar destroy } -result {} -test http-cookiejar-4.11 {cookie storage: instance} -setup { +test http-cookiejar-4.11 "cookie storage: instance" -setup { http::cookiejar create ::cookiejar oo::objdefine ::cookiejar export Database -} -constraints {sqlite3 cookiejar} -body { +} -constraints {notOSXtravis sqlite3 cookiejar} -body { cookiejar storeCookie [dict replace { key foo value bar @@ -312,10 +328,10 @@ test http-cookiejar-4.11 {cookie storage: instance} -setup { } -cleanup { ::cookiejar destroy } -result 0 -test http-cookiejar-4.12 {cookie storage: instance} -setup { +test http-cookiejar-4.12 "cookie storage: instance" -setup { http::cookiejar create ::cookiejar oo::objdefine ::cookiejar export Database -} -constraints {sqlite3 cookiejar} -body { +} -constraints {notOSXtravis sqlite3 cookiejar} -body { cookiejar storeCookie [dict replace { key foo value bar @@ -330,10 +346,10 @@ test http-cookiejar-4.12 {cookie storage: instance} -setup { } -cleanup { ::cookiejar destroy } -result 1 -test http-cookiejar-4.13 {cookie storage: instance} -setup { +test http-cookiejar-4.13 "cookie storage: instance" -setup { http::cookiejar create ::cookiejar set result {} -} -constraints {sqlite3 cookiejar} -body { +} -constraints {notOSXtravis sqlite3 cookiejar} -body { lappend result [cookiejar getCookies http www.example.com /] cookiejar storeCookie { key foo @@ -348,10 +364,10 @@ test http-cookiejar-4.13 {cookie storage: instance} -setup { } -cleanup { ::cookiejar destroy } -result {{} {foo bar}} -test http-cookiejar-4.14 {cookie storage: instance} -setup { +test http-cookiejar-4.14 "cookie storage: instance" -setup { http::cookiejar create ::cookiejar set result {} -} -constraints {sqlite3 cookiejar} -body { +} -constraints {notOSXtravis sqlite3 cookiejar} -body { lappend result [cookiejar getCookies http www.example.com /] cookiejar storeCookie [dict replace { key foo @@ -366,10 +382,10 @@ test http-cookiejar-4.14 {cookie storage: instance} -setup { } -cleanup { ::cookiejar destroy } -result {{} {foo bar}} -test http-cookiejar-4.15 {cookie storage: instance} -setup { +test http-cookiejar-4.15 "cookie storage: instance" -setup { http::cookiejar create ::cookiejar set result {} -} -constraints {sqlite3 cookiejar} -body { +} -constraints {notOSXtravis sqlite3 cookiejar} -body { lappend result [cookiejar getCookies http www.example.com /] cookiejar storeCookie { key foo @@ -393,10 +409,10 @@ test http-cookiejar-4.15 {cookie storage: instance} -setup { } -cleanup { ::cookiejar destroy } -result {{} {foo bar}} -test http-cookiejar-4.16 {cookie storage: instance} -setup { +test http-cookiejar-4.16 "cookie storage: instance" -setup { http::cookiejar create ::cookiejar set result {} -} -constraints {sqlite3 cookiejar} -body { +} -constraints {notOSXtravis sqlite3 cookiejar} -body { lappend result [cookiejar getCookies http www.example.com /] cookiejar storeCookie { key foo1 @@ -420,17 +436,17 @@ test http-cookiejar-4.16 {cookie storage: instance} -setup { } -cleanup { ::cookiejar destroy } -result {{} {foo1 bar foo2 bar}} -test http-cookiejar-4.17 {cookie storage: instance} -setup { +test http-cookiejar-4.17 "cookie storage: instance" -setup { http::cookiejar create ::cookiejar -} -constraints {sqlite3 cookiejar} -body { +} -constraints {notOSXtravis sqlite3 cookiejar} -body { cookiejar lookup a b c d } -returnCodes error -cleanup { ::cookiejar destroy } -result {wrong # args: should be "cookiejar lookup ?host? ?key?"} -test http-cookiejar-4.18 {cookie storage: instance} -setup { +test http-cookiejar-4.18 "cookie storage: instance" -setup { http::cookiejar create ::cookiejar set result {} -} -constraints {sqlite3 cookiejar} -body { +} -constraints {notOSXtravis sqlite3 cookiejar} -body { lappend result [cookiejar lookup] lappend result [cookiejar lookup www.example.com] lappend result [catch {cookiejar lookup www.example.com foo} value] $value @@ -449,10 +465,10 @@ test http-cookiejar-4.18 {cookie storage: instance} -setup { } -cleanup { ::cookiejar destroy } -result {{} {} 1 {no such key for that host} www.example.com foo bar} -test http-cookiejar-4.19 {cookie storage: instance} -setup { +test http-cookiejar-4.19 "cookie storage: instance" -setup { http::cookiejar create ::cookiejar set result {} -} -constraints {sqlite3 cookiejar} -body { +} -constraints {notOSXtravis sqlite3 cookiejar} -body { cookiejar storeCookie { key foo value bar @@ -479,10 +495,10 @@ test http-cookiejar-4.19 {cookie storage: instance} -setup { } -cleanup { ::cookiejar destroy } -result {{www.example.com www.example.org} foo bar bar foo} -test http-cookiejar-4.20 {cookie storage: instance} -setup { +test http-cookiejar-4.20 "cookie storage: instance" -setup { http::cookiejar create ::cookiejar set result {} -} -constraints {sqlite3 cookiejar} -body { +} -constraints {notOSXtravis sqlite3 cookiejar} -body { cookiejar storeCookie { key foo1 value bar1 @@ -508,10 +524,10 @@ test http-cookiejar-4.20 {cookie storage: instance} -setup { } -cleanup { ::cookiejar destroy } -result {www.example.com {foo1 foo2} bar1 bar2} -test http-cookiejar-4.21 {cookie storage: instance} -setup { +test http-cookiejar-4.21 "cookie storage: instance" -setup { http::cookiejar create ::cookiejar set result {} -} -constraints {sqlite3 cookiejar} -body { +} -constraints {notOSXtravis sqlite3 cookiejar} -body { cookiejar storeCookie { key foo1 value bar1 @@ -537,25 +553,25 @@ test http-cookiejar-4.21 {cookie storage: instance} -setup { } -cleanup { ::cookiejar destroy } -result {www.example.com {foo1 foo2} bar1 bar2} -test http-cookiejar-4.22 {cookie storage: instance} -setup { +test http-cookiejar-4.22 "cookie storage: instance" -setup { http::cookiejar create ::cookiejar set result {} -} -constraints {sqlite3 cookiejar} -body { +} -constraints {notOSXtravis sqlite3 cookiejar} -body { cookiejar forceLoadDomainData x y z } -returnCodes error -cleanup { ::cookiejar destroy } -result {wrong # args: should be "cookiejar forceLoadDomainData"} -test http-cookiejar-4.23 {cookie storage: instance} -setup { +test http-cookiejar-4.23 "cookie storage: instance" -setup { http::cookiejar create ::cookiejar set result {} -} -constraints {sqlite3 cookiejar} -body { +} -constraints {notOSXtravis sqlite3 cookiejar} -body { cookiejar forceLoadDomainData } -cleanup { ::cookiejar destroy } -result {} test http-cookiejar-4.23.a {cookie storage: instance} -setup { set off [http::cookiejar configure -offline] -} -constraints {sqlite3 cookiejar} -body { +} -constraints {notOSXtravis sqlite3 cookiejar} -body { http::cookiejar configure -offline 1 [http::cookiejar create ::cookiejar] destroy } -cleanup { @@ -564,7 +580,7 @@ test http-cookiejar-4.23.a {cookie storage: instance} -setup { } -result {} test http-cookiejar-4.23.b {cookie storage: instance} -setup { set off [http::cookiejar configure -offline] -} -constraints {sqlite3 cookiejar} -body { +} -constraints {notOSXtravis sqlite3 cookiejar} -body { http::cookiejar configure -offline 0 [http::cookiejar create ::cookiejar] destroy } -cleanup { @@ -572,10 +588,10 @@ test http-cookiejar-4.23.b {cookie storage: instance} -setup { http::cookiejar configure -offline $off } -result {} -test http-cookiejar-5.1 {cookie storage: constraints} -setup { +test http-cookiejar-5.1 "cookie storage: constraints" -setup { http::cookiejar create ::cookiejar cookiejar forceLoadDomainData -} -constraints {sqlite3 cookiejar} -body { +} -constraints {notOSXtravis sqlite3 cookiejar} -body { cookiejar storeCookie { key foo value bar @@ -589,10 +605,10 @@ test http-cookiejar-5.1 {cookie storage: constraints} -setup { } -cleanup { ::cookiejar destroy } -result {} -test http-cookiejar-5.2 {cookie storage: constraints} -setup { +test http-cookiejar-5.2 "cookie storage: constraints" -setup { http::cookiejar create ::cookiejar cookiejar forceLoadDomainData -} -constraints {sqlite3 cookiejar} -body { +} -constraints {notOSXtravis sqlite3 cookiejar} -body { cookiejar storeCookie { key foo value bar @@ -606,10 +622,10 @@ test http-cookiejar-5.2 {cookie storage: constraints} -setup { } -cleanup { ::cookiejar destroy } -result {} -test http-cookiejar-5.3 {cookie storage: constraints} -setup { +test http-cookiejar-5.3 "cookie storage: constraints" -setup { http::cookiejar create ::cookiejar cookiejar forceLoadDomainData -} -constraints {sqlite3 cookiejar} -body { +} -constraints {notOSXtravis sqlite3 cookiejar} -body { cookiejar storeCookie { key foo1 value bar @@ -632,10 +648,10 @@ test http-cookiejar-5.3 {cookie storage: constraints} -setup { } -cleanup { ::cookiejar destroy } -result {example.com} -test http-cookiejar-5.4 {cookie storage: constraints} -setup { +test http-cookiejar-5.4 "cookie storage: constraints" -setup { http::cookiejar create ::cookiejar cookiejar forceLoadDomainData -} -constraints {sqlite3 cookiejar} -body { +} -constraints {notOSXtravis sqlite3 cookiejar} -body { cookiejar storeCookie { key foo value bar1 @@ -658,10 +674,10 @@ test http-cookiejar-5.4 {cookie storage: constraints} -setup { } -cleanup { ::cookiejar destroy } -result {example.com www.example.com} -test http-cookiejar-5.5 {cookie storage: constraints} -setup { +test http-cookiejar-5.5 "cookie storage: constraints" -setup { http::cookiejar create ::cookiejar cookiejar forceLoadDomainData -} -constraints {sqlite3 cookiejar} -body { +} -constraints {notOSXtravis sqlite3 cookiejar} -body { cookiejar storeCookie { key foo1 value 1 @@ -751,7 +767,7 @@ test http-cookiejar-5.5 {cookie storage: constraints} -setup { ::cookiejar destroy } -result {{foo3 3 foo6 6} {foo3 3} {foo3 3 foo6 6 foo8 8} {foo3 3 foo5 5}} -test http-cookiejar-6.1 {cookie storage: expiry and lookup} -setup { +test http-cookiejar-6.1 "cookie storage: expiry and lookup" -setup { http::cookiejar create ::cookiejar oo::objdefine cookiejar export PurgeCookies set result {} @@ -759,7 +775,7 @@ test http-cookiejar-6.1 {cookie storage: expiry and lookup} -setup { global result lappend result [lsort [lmap {k v} $cookies {set v}]] } -} -constraints {sqlite3 cookiejar} -body { +} -constraints {notOSXtravis sqlite3 cookiejar} -body { values [cookiejar getCookies http www.example.com /] cookiejar storeCookie { key foo @@ -811,11 +827,11 @@ test http-cookiejar-6.1 {cookie storage: expiry and lookup} -setup { ::cookiejar destroy } -result {{} session cookie {cookie session-global} {cookie session-global} session-global {}} -test http-cookiejar-7.1 {cookie storage: persistence of persistent cookies} -setup { +test http-cookiejar-7.1 "cookie storage: persistence of persistent cookies" -setup { catch {rename ::cookiejar ""} set f [makeFile "" cookiejar] file delete $f -} -constraints {sqlite3 cookiejar} -body { +} -constraints {notOSXtravis sqlite3 cookiejar} -body { http::cookiejar create ::cookiejar $f ::cookiejar destroy http::cookiejar create ::cookiejar $f @@ -823,12 +839,12 @@ test http-cookiejar-7.1 {cookie storage: persistence of persistent cookies} -set catch {rename ::cookiejar ""} removeFile $f } -result ::cookiejar -test http-cookiejar-7.2 {cookie storage: persistence of persistent cookies} -setup { +test http-cookiejar-7.2 "cookie storage: persistence of persistent cookies" -setup { catch {rename ::cookiejar ""} set f [makeFile "" cookiejar] file delete $f set result {} -} -constraints {sqlite3 cookiejar} -body { +} -constraints {notOSXtravis sqlite3 cookiejar} -body { http::cookiejar create ::cookiejar $f cookiejar storeCookie [dict replace { key foo -- cgit v0.12 From 511765faae09dd5a56da42a2df297514cff7df3e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 15 Nov 2018 19:13:55 +0000 Subject: Add entry for Tcl_StaticPackage in internal stub table, since the public one is deprecated and will be removed in 9.0 Clean-up a lot of type-casts, which are not necessary any more. --- generic/tclCompile.h | 2 +- generic/tclDate.c | 2 +- generic/tclGetDate.y | 2 +- generic/tclIO.h | 2 +- generic/tclInt.decls | 4 + generic/tclInt.h | 32 ++-- generic/tclIntDecls.h | 10 ++ generic/tclOOInt.h | 4 +- generic/tclOOMethod.c | 50 +++--- generic/tclStubInit.c | 3 + generic/tclTest.c | 457 ++++++++++++++++++++++++------------------------ generic/tclThreadTest.c | 2 +- generic/tclZipfs.c | 62 +++---- generic/tclZlib.c | 36 ++-- 14 files changed, 340 insertions(+), 328 deletions(-) diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 3e349b2..e5a8d52 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -266,7 +266,7 @@ typedef struct AuxDataType { typedef struct AuxData { const AuxDataType *type; /* Pointer to the AuxData type associated with * this ClientData. */ - ClientData clientData; /* The compilation data itself. */ + void *clientData; /* The compilation data itself. */ } AuxData; /* diff --git a/generic/tclDate.c b/generic/tclDate.c index f720325..32c71de 100644 --- a/generic/tclDate.c +++ b/generic/tclDate.c @@ -2744,7 +2744,7 @@ TclDatelex( int TclClockOldscanObjCmd( - ClientData clientData, /* Unused */ + void *clientData, /* Unused */ Tcl_Interp *interp, /* Tcl interpreter */ int objc, /* Count of paraneters */ Tcl_Obj *const *objv) /* Parameters */ diff --git a/generic/tclGetDate.y b/generic/tclGetDate.y index 9c67227..59f85bd 100644 --- a/generic/tclGetDate.y +++ b/generic/tclGetDate.y @@ -960,7 +960,7 @@ TclDatelex( int TclClockOldscanObjCmd( - ClientData clientData, /* Unused */ + void *clientData, /* Unused */ Tcl_Interp *interp, /* Tcl interpreter */ int objc, /* Count of paraneters */ Tcl_Obj *const *objv) /* Parameters */ diff --git a/generic/tclIO.h b/generic/tclIO.h index 07c54fa..15f0f78 100644 --- a/generic/tclIO.h +++ b/generic/tclIO.h @@ -96,7 +96,7 @@ typedef struct EventScriptRecord { typedef struct Channel { struct ChannelState *state; /* Split out state information */ - ClientData instanceData; /* Instance-specific data provided by creator + void *instanceData; /* Instance-specific data provided by creator * of channel. */ const Tcl_ChannelType *typePtr; /* Pointer to channel type structure. */ struct Channel *downChanPtr;/* Refers to channel this one was stacked diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 4c08fca..106b4e9 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -1024,6 +1024,10 @@ declare 256 { int TclPtrUnsetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags) } +declare 257 { + void TclStaticPackage(Tcl_Interp *interp, const char *pkgName, + Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc) +} ############################################################################## diff --git a/generic/tclInt.h b/generic/tclInt.h index ed1fb68..cea0179 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -272,7 +272,7 @@ typedef struct Namespace { * synonym. */ char *fullName; /* The namespace's fully qualified name. This * starts with ::. */ - ClientData clientData; /* An arbitrary value associated with this + void *clientData; /* An arbitrary value associated with this * namespace. */ Tcl_NamespaceDeleteProc *deleteProc; /* Procedure invoked when deleting the @@ -543,7 +543,7 @@ typedef struct EnsembleConfig { typedef struct VarTrace { Tcl_VarTraceProc *traceProc;/* Procedure to call when operations given by * flags are performed on variable. */ - ClientData clientData; /* Argument to pass to proc. */ + void *clientData; /* Argument to pass to proc. */ int flags; /* What events the trace procedure is * interested in: OR-ed combination of * TCL_TRACE_READS, TCL_TRACE_WRITES, @@ -562,7 +562,7 @@ typedef struct CommandTrace { Tcl_CommandTraceProc *traceProc; /* Procedure to call when operations given by * flags are performed on command. */ - ClientData clientData; /* Argument to pass to proc. */ + void *clientData; /* Argument to pass to proc. */ int flags; /* What events the trace procedure is * interested in: OR-ed combination of * TCL_TRACE_RENAME, TCL_TRACE_DELETE. */ @@ -955,7 +955,7 @@ typedef struct CompiledLocal { /* Customized variable resolution info * supplied by the Tcl_ResolveCompiledVarProc * associated with a namespace. Each variable - * is marked by a unique ClientData tag during + * is marked by a unique tag during * compilation, and that same tag is used to * find the variable at runtime. */ char name[1]; /* Name of the local variable starts here. If @@ -1016,7 +1016,7 @@ typedef struct Trace { int level; /* Only trace commands at nesting level less * than or equal to this. */ Tcl_CmdObjTraceProc *proc; /* Procedure to call to trace command. */ - ClientData clientData; /* Arbitrary value to pass to proc. */ + void *clientData; /* Arbitrary value to pass to proc. */ struct Trace *nextPtr; /* Next in list of traces for this interp. */ int flags; /* Flags governing the trace - see * Tcl_CreateObjTrace for details. */ @@ -1068,7 +1068,7 @@ typedef struct ActiveInterpTrace { typedef struct AssocData { Tcl_InterpDeleteProc *proc; /* Proc to call when deleting. */ - ClientData clientData; /* Value to pass to proc. */ + void *clientData; /* Value to pass to proc. */ } AssocData; /* @@ -1146,7 +1146,7 @@ typedef struct CallFrame { * recognized by the compiler. The compiler * emits code that refers to these variables * using an index into this array. */ - ClientData clientData; /* Pointer to some context that is used by + void *clientData; /* Pointer to some context that is used by * object systems. The meaning of the contents * of this field is defined by the code that * sets it, and it should only ever be set by @@ -1334,13 +1334,13 @@ typedef struct ContLineLoc { * by [info frame]. Contains a sub-structure for each extra field. */ -typedef Tcl_Obj * (GetFrameInfoValueProc)(ClientData clientData); +typedef Tcl_Obj * (GetFrameInfoValueProc)(void *clientData); typedef struct { const char *name; /* Name of this field. */ GetFrameInfoValueProc *proc; /* Function to generate a Tcl_Obj* from the * clientData, or just use the clientData * directly (after casting) if NULL. */ - ClientData clientData; /* Context for above function, or Tcl_Obj* if + void *clientData; /* Context for above function, or Tcl_Obj* if * proc field is NULL. */ } ExtraFrameInfoField; typedef struct { @@ -1596,7 +1596,7 @@ typedef struct { Tcl_ObjCmdProc *proc; /* The implementation of the subcommand. */ CompileProc *compileProc; /* The compiler for the subcommand. */ Tcl_ObjCmdProc *nreProc; /* NRE implementation of this command. */ - ClientData clientData; /* Any clientData to give the command. */ + void *clientData; /* Any clientData to give the command. */ int unsafe; /* Whether this command is to be hidden by * default in a safe interpreter. */ } EnsembleImplMap; @@ -1673,13 +1673,13 @@ typedef struct Command { CompileProc *compileProc; /* Procedure called to compile command. NULL * if no compile proc exists for command. */ Tcl_ObjCmdProc *objProc; /* Object-based command procedure. */ - ClientData objClientData; /* Arbitrary value passed to object proc. */ + void *objClientData; /* Arbitrary value passed to object proc. */ Tcl_CmdProc *proc; /* String-based command procedure. */ - ClientData clientData; /* Arbitrary value passed to string proc. */ + void *clientData; /* Arbitrary value passed to string proc. */ Tcl_CmdDeleteProc *deleteProc; /* Procedure invoked when deleting command to, * e.g., free all client data. */ - ClientData deleteData; /* Arbitrary value passed to deleteProc. */ + void *deleteData; /* Arbitrary value passed to deleteProc. */ int flags; /* Miscellaneous bits of information about * command. See below for definitions. */ ImportRef *importRefPtr; /* List of each imported Command created in @@ -1845,7 +1845,7 @@ typedef struct Interp { /* Hash table used by tclBasic.c to keep track * of hidden commands on a per-interp * basis. */ - ClientData interpInfo; /* Information used by tclInterp.c to keep + void *interpInfo; /* Information used by tclInterp.c to keep * track of master/slave interps on a * per-interp basis. */ union { @@ -2861,7 +2861,7 @@ typedef struct ForIterData { typedef void* TclFindSymbolProc(Tcl_Interp* interp, Tcl_LoadHandle loadHandle, const char* symbol); struct Tcl_LoadHandle_ { - ClientData clientData; /* Client data is the load handle in the + void *clientData; /* Client data is the load handle in the * native filesystem if a module was loaded * there, or an opaque pointer to a structure * for further bookkeeping on load-from-VFS @@ -3329,7 +3329,7 @@ MODULE_SCOPE int TclChanPushObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE void TclClockInit(Tcl_Interp *interp); MODULE_SCOPE int TclClockOldscanObjCmd( - ClientData clientData, Tcl_Interp *interp, + void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_CloseObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 03a2ed2..7131ce8 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -649,6 +649,11 @@ EXTERN int TclPtrObjMakeUpvar(Tcl_Interp *interp, EXTERN int TclPtrUnsetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags); +/* 257 */ +EXTERN void TclStaticPackage(Tcl_Interp *interp, + const char *pkgName, + Tcl_PackageInitProc *initProc, + Tcl_PackageInitProc *safeInitProc); typedef struct TclIntStubs { int magic; @@ -911,6 +916,7 @@ typedef struct TclIntStubs { Tcl_Obj * (*tclPtrIncrObjVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, const int flags); /* 254 */ int (*tclPtrObjMakeUpvar) (Tcl_Interp *interp, Tcl_Var otherPtr, Tcl_Obj *myNamePtr, int myFlags); /* 255 */ int (*tclPtrUnsetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags); /* 256 */ + void (*tclStaticPackage) (Tcl_Interp *interp, const char *pkgName, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); /* 257 */ } TclIntStubs; extern const TclIntStubs *tclIntStubsPtr; @@ -1352,6 +1358,8 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclPtrObjMakeUpvar) /* 255 */ #define TclPtrUnsetVar \ (tclIntStubsPtr->tclPtrUnsetVar) /* 256 */ +#define TclStaticPackage \ + (tclIntStubsPtr->tclStaticPackage) /* 257 */ #endif /* defined(USE_TCL_STUBS) */ @@ -1382,6 +1390,8 @@ extern const TclIntStubs *tclIntStubsPtr; # undef TclGetCommandFullName # undef TclCopyChannelOld # undef TclSockMinimumBuffersOld +# undef Tcl_StaticPackage +# define Tcl_StaticPackage (tclIntStubsPtr->tclStaticPackage) #endif #endif /* _TCLINTDECLS */ diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index cde8d91..c1a9010 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -47,7 +47,7 @@ typedef struct Method { * special flag record which is just used for * the setting of the flags field. */ int refCount; - ClientData clientData; /* Type-specific data. */ + void *clientData; /* Type-specific data. */ Tcl_Obj *namePtr; /* Name of the method. */ struct Object *declaringObjectPtr; /* The object that declares this method, or @@ -84,7 +84,7 @@ typedef struct ProcedureMethod { * body bytecodes. */ int flags; /* Flags to control features. */ int refCount; - ClientData clientData; + void *clientData; TclOO_PmCDDeleteProc *deleteClientdataProc; TclOO_PmCDCloneProc *cloneClientdataProc; ProcErrorProc *errProc; /* Replacement error handler. */ diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index 545cb47..1cfd215 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -67,7 +67,7 @@ static Tcl_Obj ** InitEnsembleRewrite(Tcl_Interp *interp, int objc, Tcl_Obj *const *objv, int toRewrite, int rewriteLength, Tcl_Obj *const *rewriteObjs, int *lengthPtr); -static int InvokeProcedureMethod(ClientData clientData, +static int InvokeProcedureMethod(void *clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); static Tcl_NRPostProc FinalizeForwardCall; @@ -77,22 +77,22 @@ static int PushMethodCallFrame(Tcl_Interp *interp, int objc, Tcl_Obj *const *objv, PMFrameData *fdPtr); static void DeleteProcedureMethodRecord(ProcedureMethod *pmPtr); -static void DeleteProcedureMethod(ClientData clientData); +static void DeleteProcedureMethod(void *clientData); static int CloneProcedureMethod(Tcl_Interp *interp, - ClientData clientData, ClientData *newClientData); + void *clientData, void **newClientData); static void MethodErrorHandler(Tcl_Interp *interp, Tcl_Obj *procNameObj); static void ConstructorErrorHandler(Tcl_Interp *interp, Tcl_Obj *procNameObj); static void DestructorErrorHandler(Tcl_Interp *interp, Tcl_Obj *procNameObj); -static Tcl_Obj * RenderDeclarerName(ClientData clientData); -static int InvokeForwardMethod(ClientData clientData, +static Tcl_Obj * RenderDeclarerName(void *clientData); +static int InvokeForwardMethod(void *clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); -static void DeleteForwardMethod(ClientData clientData); +static void DeleteForwardMethod(void *clientData); static int CloneForwardMethod(Tcl_Interp *interp, - ClientData clientData, ClientData *newClientData); + void *clientData, void **newClientData); static int ProcedureMethodVarResolver(Tcl_Interp *interp, const char *varName, Tcl_Namespace *contextNs, int flags, Tcl_Var *varPtr); @@ -146,7 +146,7 @@ Tcl_NewInstanceMethod( /* The type of method this is, which defines * how to invoke, delete and clone the * method. */ - ClientData clientData) /* Some data associated with the particular + void *clientData) /* Some data associated with the particular * method to be created. */ { register Object *oPtr = (Object *) object; @@ -218,7 +218,7 @@ Tcl_NewMethod( /* The type of method this is, which defines * how to invoke, delete and clone the * method. */ - ClientData clientData) /* Some data associated with the particular + void *clientData) /* Some data associated with the particular * method to be created. */ { register Class *clsPtr = (Class *) cls; @@ -458,7 +458,7 @@ TclOOMakeProcInstanceMethod( * NULL. */ const Tcl_MethodType *typePtr, /* The type of the method to create. */ - ClientData clientData, /* The per-method type-specific data. */ + void *clientData, /* The per-method type-specific data. */ Proc **procPtrPtr) /* A pointer to the variable in which to write * the procedure record reference. Presumably * inside the structure indicated by the @@ -571,7 +571,7 @@ TclOOMakeProcMethod( * NULL. */ const Tcl_MethodType *typePtr, /* The type of the method to create. */ - ClientData clientData, /* The per-method type-specific data. */ + void *clientData, /* The per-method type-specific data. */ Proc **procPtrPtr) /* A pointer to the variable in which to write * the procedure record reference. Presumably * inside the structure indicated by the @@ -666,7 +666,7 @@ TclOOMakeProcMethod( static int InvokeProcedureMethod( - ClientData clientData, /* Pointer to some per-method context. */ + void *clientData, /* Pointer to some per-method context. */ Tcl_Interp *interp, Tcl_ObjectContext context, /* The method calling context. */ int objc, /* Number of arguments. */ @@ -745,7 +745,7 @@ InvokeProcedureMethod( static int FinalizePMCall( - ClientData data[], + void *data[], Tcl_Interp *interp, int result) { @@ -1152,7 +1152,7 @@ ProcedureMethodCompiledVarResolver( static Tcl_Obj * RenderDeclarerName( - ClientData clientData) + void *clientData) { struct PNI *pni = clientData; Tcl_Object object = Tcl_MethodDeclarerObject(pni->method); @@ -1294,7 +1294,7 @@ DeleteProcedureMethodRecord( static void DeleteProcedureMethod( - ClientData clientData) + void *clientData) { register ProcedureMethod *pmPtr = clientData; @@ -1306,8 +1306,8 @@ DeleteProcedureMethod( static int CloneProcedureMethod( Tcl_Interp *interp, - ClientData clientData, - ClientData *newClientData) + void *clientData, + void **newClientData) { ProcedureMethod *pmPtr = clientData; ProcedureMethod *pm2Ptr; @@ -1460,7 +1460,7 @@ TclOONewForwardMethod( static int InvokeForwardMethod( - ClientData clientData, /* Pointer to some per-method context. */ + void *clientData, /* Pointer to some per-method context. */ Tcl_Interp *interp, Tcl_ObjectContext context, /* The method calling context. */ int objc, /* Number of arguments. */ @@ -1494,7 +1494,7 @@ InvokeForwardMethod( static int FinalizeForwardCall( - ClientData data[], + void *data[], Tcl_Interp *interp, int result) { @@ -1516,7 +1516,7 @@ FinalizeForwardCall( static void DeleteForwardMethod( - ClientData clientData) + void *clientData) { ForwardMethod *fmPtr = clientData; @@ -1527,8 +1527,8 @@ DeleteForwardMethod( static int CloneForwardMethod( Tcl_Interp *interp, - ClientData clientData, - ClientData *newClientData) + void *clientData, + void **newClientData) { ForwardMethod *fmPtr = clientData; ForwardMethod *fm2Ptr = ckalloc(sizeof(ForwardMethod)); @@ -1677,7 +1677,7 @@ int Tcl_MethodIsType( Tcl_Method method, const Tcl_MethodType *typePtr, - ClientData *clientDataPtr) + void **clientDataPtr) { Method *mPtr = (Method *) method; @@ -1715,7 +1715,7 @@ TclOONewProcInstanceMethodEx( TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, ProcErrorProc *errProc, - ClientData clientData, + void *clientData, Tcl_Obj *nameObj, /* The name of the method, which must not be * NULL. */ Tcl_Obj *argsObj, /* The formal argument list for the method, @@ -1752,7 +1752,7 @@ TclOONewProcMethodEx( TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, ProcErrorProc *errProc, - ClientData clientData, + void *clientData, Tcl_Obj *nameObj, /* The name of the method, which may be NULL; * if so, up to caller to manage storage * (e.g., because it is a constructor or diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 4f42e0c..f58c7f1 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -56,6 +56,8 @@ #undef TclWinGetSockOpt #undef TclWinSetSockOpt #undef TclWinNToHS +#undef TclStaticPackage +#define TclStaticPackage Tcl_StaticPackage /* See bug 510001: TclSockMinimumBuffers needs plat imp */ #if defined(_WIN64) || defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8 @@ -807,6 +809,7 @@ static const TclIntStubs tclIntStubs = { TclPtrIncrObjVar, /* 254 */ TclPtrObjMakeUpvar, /* 255 */ TclPtrUnsetVar, /* 256 */ + TclStaticPackage, /* 257 */ }; static const TclIntPlatStubs tclIntPlatStubs = { diff --git a/generic/tclTest.c b/generic/tclTest.c index 37e5a2f..0e298ee 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -159,227 +159,227 @@ static TestChannel *firstDetached; * Forward declarations for procedures defined later in this file: */ -static int AsyncHandlerProc(ClientData clientData, +static int AsyncHandlerProc(void *clientData, Tcl_Interp *interp, int code); #if TCL_THREADS -static Tcl_ThreadCreateType AsyncThreadProc(ClientData); +static Tcl_ThreadCreateType AsyncThreadProc(void *); #endif static void CleanupTestSetassocdataTests( - ClientData clientData, Tcl_Interp *interp); -static void CmdDelProc1(ClientData clientData); -static void CmdDelProc2(ClientData clientData); -static int CmdProc1(ClientData clientData, + void *clientData, Tcl_Interp *interp); +static void CmdDelProc1(void *clientData); +static void CmdDelProc2(void *clientData); +static int CmdProc1(void *clientData, Tcl_Interp *interp, int argc, const char **argv); -static int CmdProc2(ClientData clientData, +static int CmdProc2(void *clientData, Tcl_Interp *interp, int argc, const char **argv); static void CmdTraceDeleteProc( - ClientData clientData, Tcl_Interp *interp, + void *clientData, Tcl_Interp *interp, int level, char *command, Tcl_CmdProc *cmdProc, - ClientData cmdClientData, int argc, + void *cmdClientData, int argc, const char *argv[]); -static void CmdTraceProc(ClientData clientData, +static void CmdTraceProc(void *clientData, Tcl_Interp *interp, int level, char *command, - Tcl_CmdProc *cmdProc, ClientData cmdClientData, + Tcl_CmdProc *cmdProc, void *cmdClientData, int argc, const char *argv[]); static int CreatedCommandProc( - ClientData clientData, Tcl_Interp *interp, + void *clientData, Tcl_Interp *interp, int argc, const char **argv); static int CreatedCommandProc2( - ClientData clientData, Tcl_Interp *interp, + void *clientData, Tcl_Interp *interp, int argc, const char **argv); -static void DelCallbackProc(ClientData clientData, +static void DelCallbackProc(void *clientData, Tcl_Interp *interp); -static int DelCmdProc(ClientData clientData, +static int DelCmdProc(void *clientData, Tcl_Interp *interp, int argc, const char **argv); -static void DelDeleteProc(ClientData clientData); -static void EncodingFreeProc(ClientData clientData); -static int EncodingToUtfProc(ClientData clientData, +static void DelDeleteProc(void *clientData); +static void EncodingFreeProc(void *clientData); +static int EncodingToUtfProc(void *clientData, const char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); -static int EncodingFromUtfProc(ClientData clientData, +static int EncodingFromUtfProc(void *clientData, const char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); -static void ExitProcEven(ClientData clientData); -static void ExitProcOdd(ClientData clientData); -static int GetTimesObjCmd(ClientData clientData, +static void ExitProcEven(void *clientData); +static void ExitProcOdd(void *clientData); +static int GetTimesObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static void MainLoop(void); -static int NoopCmd(ClientData clientData, +static int NoopCmd(void *clientData, Tcl_Interp *interp, int argc, const char **argv); -static int NoopObjCmd(ClientData clientData, +static int NoopObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int ObjTraceProc(ClientData clientData, +static int ObjTraceProc(void *clientData, Tcl_Interp *interp, int level, const char *command, Tcl_Command commandToken, int objc, Tcl_Obj *const objv[]); -static void ObjTraceDeleteProc(ClientData clientData); +static void ObjTraceDeleteProc(void *clientData); static void PrintParse(Tcl_Interp *interp, Tcl_Parse *parsePtr); static void SpecialFree(char *blockPtr); static int StaticInitProc(Tcl_Interp *interp); -static int TestasyncCmd(ClientData dummy, +static int TestasyncCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); -static int TestbytestringObjCmd(ClientData clientData, +static int TestbytestringObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int TeststringbytesObjCmd(ClientData clientData, +static int TeststringbytesObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int TestcmdinfoCmd(ClientData dummy, +static int TestcmdinfoCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); -static int TestcmdtokenCmd(ClientData dummy, +static int TestcmdtokenCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); -static int TestcmdtraceCmd(ClientData dummy, +static int TestcmdtraceCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); -static int TestconcatobjCmd(ClientData dummy, +static int TestconcatobjCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); -static int TestcreatecommandCmd(ClientData dummy, +static int TestcreatecommandCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); -static int TestdcallCmd(ClientData dummy, +static int TestdcallCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); -static int TestdelCmd(ClientData dummy, +static int TestdelCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); -static int TestdelassocdataCmd(ClientData dummy, +static int TestdelassocdataCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); -static int TestdoubledigitsObjCmd(ClientData dummy, +static int TestdoubledigitsObjCmd(void *dummy, Tcl_Interp* interp, int objc, Tcl_Obj* const objv[]); -static int TestdstringCmd(ClientData dummy, +static int TestdstringCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); -static int TestencodingObjCmd(ClientData dummy, +static int TestencodingObjCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int TestevalexObjCmd(ClientData dummy, +static int TestevalexObjCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int TestevalobjvObjCmd(ClientData dummy, +static int TestevalobjvObjCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int TesteventObjCmd(ClientData unused, +static int TesteventObjCmd(void *unused, Tcl_Interp *interp, int argc, Tcl_Obj *const objv[]); static int TesteventProc(Tcl_Event *event, int flags); static int TesteventDeleteProc(Tcl_Event *event, - ClientData clientData); -static int TestexithandlerCmd(ClientData dummy, + void *clientData); +static int TestexithandlerCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); -static int TestexprlongCmd(ClientData dummy, +static int TestexprlongCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); -static int TestexprlongobjCmd(ClientData dummy, +static int TestexprlongobjCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int TestexprdoubleCmd(ClientData dummy, +static int TestexprdoubleCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); -static int TestexprdoubleobjCmd(ClientData dummy, +static int TestexprdoubleobjCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int TestexprparserObjCmd(ClientData dummy, +static int TestexprparserObjCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int TestexprstringCmd(ClientData dummy, +static int TestexprstringCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); -static int TestfileCmd(ClientData dummy, +static int TestfileCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int TestfilelinkCmd(ClientData dummy, +static int TestfilelinkCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int TestfeventCmd(ClientData dummy, +static int TestfeventCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); -static int TestgetassocdataCmd(ClientData dummy, +static int TestgetassocdataCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); -static int TestgetintCmd(ClientData dummy, +static int TestgetintCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); -static int TestlongsizeCmd(ClientData dummy, +static int TestlongsizeCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); -static int TestgetplatformCmd(ClientData dummy, +static int TestgetplatformCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestgetvarfullnameCmd( - ClientData dummy, Tcl_Interp *interp, + void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int TestinterpdeleteCmd(ClientData dummy, +static int TestinterpdeleteCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); -static int TestlinkCmd(ClientData dummy, +static int TestlinkCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); -static int TestlocaleCmd(ClientData dummy, +static int TestlocaleCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int TestmainthreadCmd(ClientData dummy, +static int TestmainthreadCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); -static int TestsetmainloopCmd(ClientData dummy, +static int TestsetmainloopCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); -static int TestexitmainloopCmd(ClientData dummy, +static int TestexitmainloopCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); -static int TestpanicCmd(ClientData dummy, +static int TestpanicCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); -static int TestparseargsCmd(ClientData dummy, Tcl_Interp *interp, +static int TestparseargsCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int TestparserObjCmd(ClientData dummy, +static int TestparserObjCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int TestparsevarObjCmd(ClientData dummy, +static int TestparsevarObjCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int TestparsevarnameObjCmd(ClientData dummy, +static int TestparsevarnameObjCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int TestpreferstableObjCmd(ClientData dummy, +static int TestpreferstableObjCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int TestprintObjCmd(ClientData dummy, +static int TestprintObjCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int TestregexpObjCmd(ClientData dummy, +static int TestregexpObjCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int TestreturnObjCmd(ClientData dummy, +static int TestreturnObjCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static void TestregexpXflags(const char *string, int length, int *cflagsPtr, int *eflagsPtr); -static int TestsaveresultCmd(ClientData dummy, +static int TestsaveresultCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static void TestsaveresultFree(char *blockPtr); -static int TestsetassocdataCmd(ClientData dummy, +static int TestsetassocdataCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); -static int TestsetCmd(ClientData dummy, +static int TestsetCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); -static int Testset2Cmd(ClientData dummy, +static int Testset2Cmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); -static int TestseterrorcodeCmd(ClientData dummy, +static int TestseterrorcodeCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestsetobjerrorcodeCmd( - ClientData dummy, Tcl_Interp *interp, + void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int TestsetplatformCmd(ClientData dummy, +static int TestsetplatformCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); -static int TeststaticpkgCmd(ClientData dummy, +static int TeststaticpkgCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); -static int TesttranslatefilenameCmd(ClientData dummy, +static int TesttranslatefilenameCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); -static int TestupvarCmd(ClientData dummy, +static int TestupvarCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestWrongNumArgsObjCmd( - ClientData clientData, Tcl_Interp *interp, + void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int TestGetIndexFromObjStructObjCmd( - ClientData clientData, Tcl_Interp *interp, + void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int TestChannelCmd(ClientData clientData, +static int TestChannelCmd(void *clientData, Tcl_Interp *interp, int argc, const char **argv); -static int TestChannelEventCmd(ClientData clientData, +static int TestChannelEventCmd(void *clientData, Tcl_Interp *interp, int argc, const char **argv); -static int TestSocketCmd(ClientData clientData, +static int TestSocketCmd(void *clientData, Tcl_Interp *interp, int argc, const char **argv); -static int TestFilesystemObjCmd(ClientData dummy, +static int TestFilesystemObjCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int TestSimpleFilesystemObjCmd( - ClientData dummy, Tcl_Interp *interp, int objc, + void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static void TestReport(const char *cmd, Tcl_Obj *arg1, Tcl_Obj *arg2); @@ -415,39 +415,35 @@ static Tcl_FSListVolumesProc SimpleListVolumes; static Tcl_FSPathInFilesystemProc SimplePathInFilesystem; static Tcl_Obj * SimpleRedirect(Tcl_Obj *pathPtr); static Tcl_FSMatchInDirectoryProc SimpleMatchInDirectory; -static int TestNumUtfCharsCmd(ClientData clientData, +static int TestNumUtfCharsCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int TestFindFirstCmd(ClientData clientData, +static int TestFindFirstCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int TestFindLastCmd(ClientData clientData, +static int TestFindLastCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int TestHashSystemHashCmd(ClientData clientData, +static int TestHashSystemHashCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static Tcl_NRPostProc NREUnwind_callback; -static int TestNREUnwind(ClientData clientData, +static int TestNREUnwind(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int TestNRELevels(ClientData clientData, +static int TestNRELevels(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int TestInterpResolverCmd(ClientData clientData, +static int TestInterpResolverCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); #if defined(HAVE_CPUID) || defined(_WIN32) -static int TestcpuidCmd(ClientData dummy, +static int TestcpuidCmd(void *dummy, Tcl_Interp* interp, int objc, Tcl_Obj *const objv[]); #endif -#ifdef __GNUC__ -#pragma GCC diagnostic ignored "-Wdeprecated-declarations" -#endif - static const Tcl_Filesystem testReportingFilesystem = { "reporting", sizeof(Tcl_Filesystem), @@ -685,9 +681,9 @@ Tcltest_Init( Tcl_CreateCommand(interp, "testsetnoerr", TestsetCmd, NULL, NULL); Tcl_CreateCommand(interp, "testseterr", TestsetCmd, - (ClientData) TCL_LEAVE_ERR_MSG, NULL); + INT2PTR(TCL_LEAVE_ERR_MSG), NULL); Tcl_CreateCommand(interp, "testset2", Testset2Cmd, - (ClientData) TCL_LEAVE_ERR_MSG, NULL); + INT2PTR(TCL_LEAVE_ERR_MSG), NULL); Tcl_CreateCommand(interp, "testseterrorcode", TestseterrorcodeCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testsetobjerrorcode", @@ -715,7 +711,7 @@ Tcltest_Init( NULL, NULL); #if defined(HAVE_CPUID) || defined(_WIN32) Tcl_CreateObjCommand(interp, "testcpuid", TestcpuidCmd, - (ClientData) 0, NULL); + NULL, NULL); #endif Tcl_CreateObjCommand(interp, "testnreunwind", TestNREUnwind, NULL, NULL); @@ -825,7 +821,7 @@ Tcltest_SafeInit( /* ARGSUSED */ static int TestasyncCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -950,7 +946,7 @@ TestasyncCmd( static int AsyncHandlerProc( - ClientData clientData, /* If of TestAsyncHandler structure. + void *clientData, /* If of TestAsyncHandler structure. * in global list. */ Tcl_Interp *interp, /* Interpreter in which command was * executed, or NULL. */ @@ -1010,7 +1006,7 @@ AsyncHandlerProc( #if TCL_THREADS static Tcl_ThreadCreateType AsyncThreadProc( - ClientData clientData) /* Parameter is the id of a + void *clientData) /* Parameter is the id of a * TestAsyncHandler, defined above. */ { TestAsyncHandler *asyncPtr; @@ -1052,7 +1048,7 @@ AsyncThreadProc( /* ARGSUSED */ static int TestcmdinfoCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -1065,7 +1061,7 @@ TestcmdinfoCmd( return TCL_ERROR; } if (strcmp(argv[1], "create") == 0) { - Tcl_CreateCommand(interp, argv[2], CmdProc1, (ClientData) "original", + Tcl_CreateCommand(interp, argv[2], CmdProc1, (void *) "original", CmdDelProc1); } else if (strcmp(argv[1], "delete") == 0) { Tcl_DStringInit(&delString); @@ -1102,11 +1098,11 @@ TestcmdinfoCmd( } } else if (strcmp(argv[1], "modify") == 0) { info.proc = CmdProc2; - info.clientData = (ClientData) "new_command_data"; + info.clientData = (void *) "new_command_data"; info.objProc = NULL; info.objClientData = NULL; info.deleteProc = CmdDelProc2; - info.deleteData = (ClientData) "new_delete_data"; + info.deleteData = (void *) "new_delete_data"; if (Tcl_SetCommandInfo(interp, argv[2], &info) == 0) { Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); } else { @@ -1123,7 +1119,7 @@ TestcmdinfoCmd( /*ARGSUSED*/ static int CmdProc1( - ClientData clientData, /* String to return. */ + void *clientData, /* String to return. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -1135,7 +1131,7 @@ CmdProc1( /*ARGSUSED*/ static int CmdProc2( - ClientData clientData, /* String to return. */ + void *clientData, /* String to return. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -1146,7 +1142,7 @@ CmdProc2( static void CmdDelProc1( - ClientData clientData) /* String to save. */ + void *clientData) /* String to save. */ { Tcl_DStringInit(&delString); Tcl_DStringAppend(&delString, "CmdDelProc1 ", -1); @@ -1155,7 +1151,7 @@ CmdDelProc1( static void CmdDelProc2( - ClientData clientData) /* String to save. */ + void *clientData) /* String to save. */ { Tcl_DStringInit(&delString); Tcl_DStringAppend(&delString, "CmdDelProc2 ", -1); @@ -1182,7 +1178,7 @@ CmdDelProc2( /* ARGSUSED */ static int TestcmdtokenCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -1198,7 +1194,7 @@ TestcmdtokenCmd( } if (strcmp(argv[1], "create") == 0) { token = Tcl_CreateCommand(interp, argv[2], CmdProc1, - (ClientData) "original", NULL); + (void *) "original", NULL); sprintf(buf, "%p", (void *)token); Tcl_AppendResult(interp, buf, NULL); } else if (strcmp(argv[1], "name") == 0) { @@ -1246,7 +1242,7 @@ TestcmdtokenCmd( /* ARGSUSED */ static int TestcmdtraceCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -1302,7 +1298,7 @@ TestcmdtraceCmd( deleteCalled = 0; cmdTrace = Tcl_CreateObjTrace(interp, 50000, TCL_ALLOW_INLINE_COMPILATION, ObjTraceProc, - (ClientData) &deleteCalled, ObjTraceDeleteProc); + &deleteCalled, ObjTraceDeleteProc); result = Tcl_EvalEx(interp, argv[2], -1, 0); Tcl_DeleteTrace(interp, cmdTrace); if (!deleteCalled) { @@ -1335,7 +1331,7 @@ TestcmdtraceCmd( static void CmdTraceProc( - ClientData clientData, /* Pointer to buffer in which the + void *clientData, /* Pointer to buffer in which the * command and arguments are appended. * Accumulates test result. */ Tcl_Interp *interp, /* Current interpreter. */ @@ -1343,7 +1339,7 @@ CmdTraceProc( char *command, /* The command being traced (after * substitutions). */ Tcl_CmdProc *cmdProc, /* Points to command's command procedure. */ - ClientData cmdClientData, /* Client data associated with command + void *cmdClientData, /* Client data associated with command * procedure. */ int argc, /* Number of arguments. */ const char *argv[]) /* Argument strings. */ @@ -1362,13 +1358,13 @@ CmdTraceProc( static void CmdTraceDeleteProc( - ClientData clientData, /* Unused. */ + void *clientData, /* Unused. */ Tcl_Interp *interp, /* Current interpreter. */ int level, /* Current trace level. */ char *command, /* The command being traced (after * substitutions). */ Tcl_CmdProc *cmdProc, /* Points to command's command procedure. */ - ClientData cmdClientData, /* Client data associated with command + void *cmdClientData, /* Client data associated with command * procedure. */ int argc, /* Number of arguments. */ const char *argv[]) /* Argument strings. */ @@ -1384,7 +1380,7 @@ CmdTraceDeleteProc( static int ObjTraceProc( - ClientData clientData, /* unused */ + void *clientData, /* unused */ Tcl_Interp *interp, /* Tcl interpreter */ int level, /* Execution level */ const char *command, /* Command being executed */ @@ -1412,7 +1408,7 @@ ObjTraceProc( static void ObjTraceDeleteProc( - ClientData clientData) + void *clientData) { int *intPtr = (int *) clientData; *intPtr = 1; /* Record that the trace was deleted */ @@ -1441,7 +1437,7 @@ ObjTraceDeleteProc( static int TestcreatecommandCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -1471,7 +1467,7 @@ TestcreatecommandCmd( static int CreatedCommandProc( - ClientData clientData, /* String to return. */ + void *clientData, /* String to return. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -1493,7 +1489,7 @@ CreatedCommandProc( static int CreatedCommandProc2( - ClientData clientData, /* String to return. */ + void *clientData, /* String to return. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -1532,7 +1528,7 @@ CreatedCommandProc2( /* ARGSUSED */ static int TestdcallCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -1547,10 +1543,10 @@ TestdcallCmd( } if (id < 0) { Tcl_DontCallWhenDeleted(delInterp, DelCallbackProc, - (ClientData) INT2PTR(-id)); + INT2PTR(-id)); } else { Tcl_CallWhenDeleted(delInterp, DelCallbackProc, - (ClientData) INT2PTR(id)); + INT2PTR(id)); } } Tcl_DeleteInterp(delInterp); @@ -1564,7 +1560,7 @@ TestdcallCmd( static void DelCallbackProc( - ClientData clientData, /* Numerical value to append to delString. */ + void *clientData, /* Numerical value to append to delString. */ Tcl_Interp *interp) /* Interpreter being deleted. */ { int id = PTR2INT(clientData); @@ -1597,7 +1593,7 @@ DelCallbackProc( /* ARGSUSED */ static int TestdelCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -1620,14 +1616,14 @@ TestdelCmd( dPtr->deleteCmd = ckalloc(strlen(argv[3]) + 1); strcpy(dPtr->deleteCmd, argv[3]); - Tcl_CreateCommand(slave, argv[2], DelCmdProc, (ClientData) dPtr, + Tcl_CreateCommand(slave, argv[2], DelCmdProc, dPtr, DelDeleteProc); return TCL_OK; } static int DelCmdProc( - ClientData clientData, /* String result to return. */ + void *clientData, /* String result to return. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -1642,7 +1638,7 @@ DelCmdProc( static void DelDeleteProc( - ClientData clientData) /* String command to evaluate. */ + void *clientData) /* String command to evaluate. */ { DelCmd *dPtr = clientData; @@ -1672,7 +1668,7 @@ DelDeleteProc( static int TestdelassocdataCmd( - ClientData clientData, /* Not used. */ + void *clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -1708,7 +1704,7 @@ TestdelassocdataCmd( */ static int -TestdoubledigitsObjCmd(ClientData unused, +TestdoubledigitsObjCmd(void *unused, /* NULL */ Tcl_Interp* interp, /* Tcl interpreter */ @@ -1802,7 +1798,7 @@ TestdoubledigitsObjCmd(ClientData unused, /* ARGSUSED */ static int TestdstringCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -1929,7 +1925,7 @@ static void SpecialFree(blockPtr) /* ARGSUSED */ static int TestencodingObjCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -1974,7 +1970,7 @@ TestencodingObjCmd( type.toUtfProc = EncodingToUtfProc; type.fromUtfProc = EncodingFromUtfProc; type.freeProc = EncodingFreeProc; - type.clientData = (ClientData) encodingPtr; + type.clientData = encodingPtr; type.nullSize = 1; Tcl_CreateEncoding(&type); @@ -1997,7 +1993,7 @@ TestencodingObjCmd( static int EncodingToUtfProc( - ClientData clientData, /* TclEncoding structure. */ + void *clientData, /* TclEncoding structure. */ const char *src, /* Source string in specified encoding. */ int srcLen, /* Source string length in bytes. */ int flags, /* Conversion control flags. */ @@ -2029,7 +2025,7 @@ EncodingToUtfProc( static int EncodingFromUtfProc( - ClientData clientData, /* TclEncoding structure. */ + void *clientData, /* TclEncoding structure. */ const char *src, /* Source string in specified encoding. */ int srcLen, /* Source string length in bytes. */ int flags, /* Conversion control flags. */ @@ -2061,7 +2057,7 @@ EncodingFromUtfProc( static void EncodingFreeProc( - ClientData clientData) /* ClientData associated with type. */ + void *clientData) /* ClientData associated with type. */ { TclEncoding *encodingPtr = clientData; @@ -2089,7 +2085,7 @@ EncodingFreeProc( static int TestevalexObjCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -2134,7 +2130,7 @@ TestevalexObjCmd( static int TestevalobjvObjCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -2183,7 +2179,7 @@ TestevalobjvObjCmd( static int TesteventObjCmd( - ClientData unused, /* Not used */ + void *unused, /* Not used */ Tcl_Interp *interp, /* Tcl interpreter */ int objc, /* Parameter count */ Tcl_Obj *const objv[]) /* Parameter vector */ @@ -2319,7 +2315,7 @@ TesteventProc( static int TesteventDeleteProc( Tcl_Event *event, /* Event to examine */ - ClientData clientData) /* Tcl_Obj containing the name of the event(s) + void *clientData) /* Tcl_Obj containing the name of the event(s) * to remove */ { TestEvent *ev; /* Event to examine */ @@ -2362,7 +2358,7 @@ TesteventDeleteProc( static int TestexithandlerCmd( - ClientData clientData, /* Not used. */ + void *clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -2379,10 +2375,10 @@ TestexithandlerCmd( } if (strcmp(argv[1], "create") == 0) { Tcl_CreateExitHandler((value & 1) ? ExitProcOdd : ExitProcEven, - (ClientData) INT2PTR(value)); + INT2PTR(value)); } else if (strcmp(argv[1], "delete") == 0) { Tcl_DeleteExitHandler((value & 1) ? ExitProcOdd : ExitProcEven, - (ClientData) INT2PTR(value)); + INT2PTR(value)); } else { Tcl_AppendResult(interp, "bad option \"", argv[1], "\": must be create or delete", NULL); @@ -2393,7 +2389,7 @@ TestexithandlerCmd( static void ExitProcOdd( - ClientData clientData) /* Integer value to print. */ + void *clientData) /* Integer value to print. */ { char buf[16 + TCL_INTEGER_SPACE]; size_t len; @@ -2407,7 +2403,7 @@ ExitProcOdd( static void ExitProcEven( - ClientData clientData) /* Integer value to print. */ + void *clientData) /* Integer value to print. */ { char buf[16 + TCL_INTEGER_SPACE]; size_t len; @@ -2438,7 +2434,7 @@ ExitProcEven( static int TestexprlongCmd( - ClientData clientData, /* Not used. */ + void *clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -2481,7 +2477,7 @@ TestexprlongCmd( static int TestexprlongobjCmd( - ClientData clientData, /* Not used. */ + void *clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const *objv) /* Argument objects. */ @@ -2523,7 +2519,7 @@ TestexprlongobjCmd( static int TestexprdoubleCmd( - ClientData clientData, /* Not used. */ + void *clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -2567,7 +2563,7 @@ TestexprdoubleCmd( static int TestexprdoubleobjCmd( - ClientData clientData, /* Not used. */ + void *clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const *objv) /* Argument objects. */ @@ -2609,7 +2605,7 @@ TestexprdoubleobjCmd( static int TestexprstringCmd( - ClientData clientData, /* Not used. */ + void *clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -2641,7 +2637,7 @@ TestexprstringCmd( static int TestfilelinkCmd( - ClientData clientData, /* Not used. */ + void *clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ @@ -2708,7 +2704,7 @@ TestfilelinkCmd( static int TestgetassocdataCmd( - ClientData clientData, /* Not used. */ + void *clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -2746,7 +2742,7 @@ TestgetassocdataCmd( static int TestgetplatformCmd( - ClientData clientData, /* Not used. */ + void *clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -2787,7 +2783,7 @@ TestgetplatformCmd( /* ARGSUSED */ static int TestinterpdeleteCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -2828,7 +2824,7 @@ TestinterpdeleteCmd( /* ARGSUSED */ static int TestlinkCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -3296,7 +3292,7 @@ TestlinkCmd( static int TestlocaleCmd( - ClientData clientData, /* Not used. */ + void *clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ @@ -3358,7 +3354,7 @@ TestlocaleCmd( /* ARGSUSED */ static void CleanupTestSetassocdataTests( - ClientData clientData, /* Data to be released. */ + void *clientData, /* Data to be released. */ Tcl_Interp *interp) /* Interpreter being deleted. */ { ckfree(clientData); @@ -3383,7 +3379,7 @@ CleanupTestSetassocdataTests( static int TestparserObjCmd( - ClientData clientData, /* Not used. */ + void *clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ @@ -3439,7 +3435,7 @@ TestparserObjCmd( static int TestexprparserObjCmd( - ClientData clientData, /* Not used. */ + void *clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ @@ -3586,7 +3582,7 @@ PrintParse( static int TestparsevarObjCmd( - ClientData clientData, /* Not used. */ + void *clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ @@ -3627,7 +3623,7 @@ TestparsevarObjCmd( static int TestparsevarnameObjCmd( - ClientData clientData, /* Not used. */ + void *clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ @@ -3690,7 +3686,7 @@ TestparsevarnameObjCmd( static int TestpreferstableObjCmd( - ClientData clientData, /* Not used. */ + void *clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ @@ -3719,7 +3715,7 @@ TestpreferstableObjCmd( static int TestprintObjCmd( - ClientData clientData, /* Not used. */ + void *clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ @@ -3761,7 +3757,7 @@ TestprintObjCmd( /* ARGSUSED */ static int TestregexpObjCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -4085,7 +4081,7 @@ TestregexpXflags( /* ARGSUSED */ static int TestreturnObjCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -4113,7 +4109,7 @@ TestreturnObjCmd( static int TestsetassocdataCmd( - ClientData clientData, /* Not used. */ + void *clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -4140,8 +4136,7 @@ TestsetassocdataCmd( ckfree(oldData); } - Tcl_SetAssocData(interp, argv[1], CleanupTestSetassocdataTests, - (ClientData) buf); + Tcl_SetAssocData(interp, argv[1], CleanupTestSetassocdataTests, buf); return TCL_OK; } @@ -4165,7 +4160,7 @@ TestsetassocdataCmd( static int TestsetplatformCmd( - ClientData clientData, /* Not used. */ + void *clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -4214,7 +4209,7 @@ TestsetplatformCmd( static int TeststaticpkgCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -4232,7 +4227,7 @@ TeststaticpkgCmd( if (Tcl_GetInt(interp, argv[3], &loaded) != TCL_OK) { return TCL_ERROR; } - tclStubsPtr->tcl_StaticPackage((loaded) ? interp : NULL, argv[1], + Tcl_StaticPackage((loaded) ? interp : NULL, argv[1], StaticInitProc, (safe) ? StaticInitProc : NULL); return TCL_OK; } @@ -4265,7 +4260,7 @@ StaticInitProc( static int TesttranslatefilenameCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -4307,7 +4302,7 @@ TesttranslatefilenameCmd( /* ARGSUSED */ static int TestupvarCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -4360,7 +4355,7 @@ TestupvarCmd( /* ARGSUSED */ static int TestseterrorcodeCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -4413,7 +4408,7 @@ TestseterrorcodeCmd( /* ARGSUSED */ static int TestsetobjerrorcodeCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ @@ -4442,7 +4437,7 @@ TestsetobjerrorcodeCmd( /* ARGSUSED */ static int TestfeventCmd( - ClientData clientData, /* Not used. */ + void *clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -4514,7 +4509,7 @@ TestfeventCmd( static int TestpanicCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -4535,7 +4530,7 @@ TestpanicCmd( static int TestfileCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ Tcl_Obj *const argv[]) /* The argument objects. */ @@ -4617,7 +4612,7 @@ TestfileCmd( static int TestgetvarfullnameCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ @@ -4691,7 +4686,7 @@ TestgetvarfullnameCmd( static int GetTimesObjCmd( - ClientData unused, /* Unused. */ + void *unused, /* Unused. */ Tcl_Interp *interp, /* The current interpreter. */ int notused1, /* Number of arguments. */ Tcl_Obj *const notused2[]) /* The argument objects. */ @@ -4870,7 +4865,7 @@ GetTimesObjCmd( static int NoopCmd( - ClientData unused, /* Unused. */ + void *unused, /* Unused. */ Tcl_Interp *interp, /* The current interpreter. */ int argc, /* The number of arguments. */ const char **argv) /* The argument strings. */ @@ -4897,7 +4892,7 @@ NoopCmd( static int NoopObjCmd( - ClientData unused, /* Not used. */ + void *unused, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ @@ -4922,7 +4917,7 @@ NoopObjCmd( static int TeststringbytesObjCmd( - ClientData unused, /* Not used. */ + void *unused, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ @@ -4958,7 +4953,7 @@ TeststringbytesObjCmd( static int TestbytestringObjCmd( - ClientData unused, /* Not used. */ + void *unused, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ @@ -4995,7 +4990,7 @@ TestbytestringObjCmd( /* ARGSUSED */ static int TestsetCmd( - ClientData data, /* Additional flags for Get/SetVar2. */ + void *data, /* Additional flags for Get/SetVar2. */ register Tcl_Interp *interp,/* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -5027,7 +5022,7 @@ TestsetCmd( } static int Testset2Cmd( - ClientData data, /* Additional flags for Get/SetVar2. */ + void *data, /* Additional flags for Get/SetVar2. */ register Tcl_Interp *interp,/* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -5078,7 +5073,7 @@ Testset2Cmd( /* ARGSUSED */ static int TestsaveresultCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ register Tcl_Interp *interp,/* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ @@ -5209,7 +5204,7 @@ TestsaveresultFree( static int TestmainthreadCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ register Tcl_Interp *interp,/* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -5270,7 +5265,7 @@ MainLoop(void) static int TestsetmainloopCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ register Tcl_Interp *interp,/* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -5299,7 +5294,7 @@ TestsetmainloopCmd( static int TestexitmainloopCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ register Tcl_Interp *interp,/* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -5328,7 +5323,7 @@ TestexitmainloopCmd( /* ARGSUSED */ static int TestChannelCmd( - ClientData clientData, /* Not used. */ + void *clientData, /* Not used. */ Tcl_Interp *interp, /* Interpreter for result. */ int argc, /* Count of additional args. */ const char **argv) /* Additional arg strings. */ @@ -5797,7 +5792,7 @@ TestChannelCmd( /* ARGSUSED */ static int TestChannelEventCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -5851,7 +5846,7 @@ TestChannelEventCmd( Tcl_IncrRefCount(esPtr->scriptPtr); Tcl_CreateChannelHandler((Tcl_Channel) chanPtr, mask, - TclChannelEventScriptInvoker, (ClientData) esPtr); + TclChannelEventScriptInvoker, esPtr); return TCL_OK; } @@ -5895,7 +5890,7 @@ TestChannelEventCmd( prevEsPtr->nextPtr = esPtr->nextPtr; } Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr, - TclChannelEventScriptInvoker, (ClientData) esPtr); + TclChannelEventScriptInvoker, esPtr); Tcl_DecrRefCount(esPtr->scriptPtr); ckfree(esPtr); @@ -5936,7 +5931,7 @@ TestChannelEventCmd( esPtr = nextEsPtr) { nextEsPtr = esPtr->nextPtr; Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr, - TclChannelEventScriptInvoker, (ClientData) esPtr); + TclChannelEventScriptInvoker, esPtr); Tcl_DecrRefCount(esPtr->scriptPtr); ckfree(esPtr); } @@ -5982,7 +5977,7 @@ TestChannelEventCmd( } esPtr->mask = mask; Tcl_CreateChannelHandler((Tcl_Channel) chanPtr, mask, - TclChannelEventScriptInvoker, (ClientData) esPtr); + TclChannelEventScriptInvoker, esPtr); return TCL_OK; } Tcl_AppendResult(interp, "bad command ", cmd, ", must be one of " @@ -6010,7 +6005,7 @@ TestChannelEventCmd( /* ARGSUSED */ static int TestSocketCmd( - ClientData clientData, /* Not used. */ + void *clientData, /* Not used. */ Tcl_Interp *interp, /* Interpreter for result. */ int argc, /* Count of additional args. */ const char **argv) /* Additional arg strings. */ @@ -6077,7 +6072,7 @@ TestSocketCmd( static int TestWrongNumArgsObjCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -6133,7 +6128,7 @@ TestWrongNumArgsObjCmd( static int TestGetIndexFromObjStructObjCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -6187,7 +6182,7 @@ TestGetIndexFromObjStructObjCmd( static int TestFilesystemObjCmd( - ClientData dummy, + void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -6203,7 +6198,7 @@ TestFilesystemObjCmd( return TCL_ERROR; } if (boolVal) { - res = Tcl_FSRegister((ClientData)interp, &testReportingFilesystem); + res = Tcl_FSRegister(interp, &testReportingFilesystem); msg = (res == TCL_OK) ? "registered" : "failed"; } else { res = Tcl_FSUnregister(&testReportingFilesystem); @@ -6216,7 +6211,7 @@ TestFilesystemObjCmd( static int TestReportInFilesystem( Tcl_Obj *pathPtr, - ClientData *clientDataPtr) + void **clientDataPtr) { static Tcl_Obj *lastPathPtr = NULL; Tcl_Obj *newPathPtr; @@ -6238,7 +6233,7 @@ TestReportInFilesystem( return -1; } lastPathPtr = NULL; - *clientDataPtr = (ClientData) newPathPtr; + *clientDataPtr = newPathPtr; return TCL_OK; } @@ -6256,7 +6251,7 @@ TestReportGetNativePath( static void TestReportFreeInternalRep( - ClientData clientData) + void *clientData) { Tcl_Obj *nativeRep = (Tcl_Obj *) clientData; @@ -6268,7 +6263,7 @@ TestReportFreeInternalRep( static ClientData TestReportDupInternalRep( - ClientData clientData) + void *clientData) { Tcl_Obj *original = (Tcl_Obj *) clientData; @@ -6534,7 +6529,7 @@ TestReportNormalizePath( static int SimplePathInFilesystem( Tcl_Obj *pathPtr, - ClientData *clientDataPtr) + void **clientDataPtr) { const char *str = Tcl_GetString(pathPtr); @@ -6563,7 +6558,7 @@ SimplePathInFilesystem( static int TestSimpleFilesystemObjCmd( - ClientData dummy, + void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -6579,7 +6574,7 @@ TestSimpleFilesystemObjCmd( return TCL_ERROR; } if (boolVal) { - res = Tcl_FSRegister((ClientData)interp, &simpleFilesystem); + res = Tcl_FSRegister(interp, &simpleFilesystem); msg = (res == TCL_OK) ? "registered" : "failed"; } else { res = Tcl_FSUnregister(&simpleFilesystem); @@ -6723,7 +6718,7 @@ SimpleListVolumes(void) static int TestNumUtfCharsCmd( - ClientData clientData, + void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -6746,7 +6741,7 @@ TestNumUtfCharsCmd( static int TestFindFirstCmd( - ClientData clientData, + void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -6768,7 +6763,7 @@ TestFindFirstCmd( static int TestFindLastCmd( - ClientData clientData, + void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -6810,7 +6805,7 @@ TestFindLastCmd( static int TestcpuidCmd( - ClientData dummy, + void *dummy, Tcl_Interp* interp, /* Tcl interpreter */ int objc, /* Parameter count */ Tcl_Obj *const * objv) /* Parameter vector */ @@ -6846,7 +6841,7 @@ TestcpuidCmd( static int TestHashSystemHashCmd( - ClientData clientData, + void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -6922,7 +6917,7 @@ TestHashSystemHashCmd( */ static int TestgetintCmd( - ClientData dummy, + void *dummy, Tcl_Interp *interp, int argc, const char **argv) @@ -6949,7 +6944,7 @@ TestgetintCmd( */ static int TestlongsizeCmd( - ClientData dummy, + void *dummy, Tcl_Interp *interp, int argc, const char **argv) @@ -6964,7 +6959,7 @@ TestlongsizeCmd( static int NREUnwind_callback( - ClientData data[], + void *data[], Tcl_Interp *interp, int result) { @@ -6991,7 +6986,7 @@ NREUnwind_callback( static int TestNREUnwind( - ClientData clientData, + void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -7009,7 +7004,7 @@ TestNREUnwind( static int TestNRELevels( - ClientData clientData, + void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -7065,7 +7060,7 @@ TestNRELevels( static int TestconcatobjCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -7362,7 +7357,7 @@ TestconcatobjCmd( static int TestparseargsCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Arguments. */ @@ -7601,7 +7596,7 @@ InterpCompiledVarResolver( static int TestInterpResolverCmd( - ClientData clientData, + void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) diff --git a/generic/tclThreadTest.c b/generic/tclThreadTest.c index 1742eb7..e9b1107 100644 --- a/generic/tclThreadTest.c +++ b/generic/tclThreadTest.c @@ -508,7 +508,7 @@ ThreadCreate( joinable = joinable ? TCL_THREAD_JOINABLE : TCL_THREAD_NOFLAGS; Tcl_MutexLock(&threadMutex); - if (Tcl_CreateThread(&id, NewTestThread, (ClientData) &ctrl, + if (Tcl_CreateThread(&id, NewTestThread, &ctrl, TCL_THREAD_STACK_DEFAULT, joinable) != TCL_OK) { Tcl_MutexUnlock(&threadMutex); Tcl_AppendResult(interp, "can't create a new thread", NULL); diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c index 4864a43..0f06d37 100644 --- a/generic/tclZipfs.c +++ b/generic/tclZipfs.c @@ -361,7 +361,7 @@ static inline int DescribeMounted(Tcl_Interp *interp, static inline int ListMountPoints(Tcl_Interp *interp); static int ZipfsAppHookFindTclInit(const char *archive); static int ZipFSPathInFilesystemProc(Tcl_Obj *pathPtr, - ClientData *clientDataPtr); + void **clientDataPtr); static Tcl_Obj * ZipFSFilesystemPathTypeProc(Tcl_Obj *pathPtr); static Tcl_Obj * ZipFSFilesystemSeparatorProc(Tcl_Obj *pathPtr); static int ZipFSStatProc(Tcl_Obj *pathPtr, Tcl_StatBuf *buf); @@ -382,17 +382,17 @@ static int ZipFSLoadFile(Tcl_Interp *interp, Tcl_Obj *path, Tcl_LoadHandle *loadHandle, Tcl_FSUnloadFileProc **unloadProcPtr, int flags); static void ZipfsSetup(void); -static int ZipChannelClose(ClientData instanceData, +static int ZipChannelClose(void *instanceData, Tcl_Interp *interp); -static int ZipChannelGetFile(ClientData instanceData, - int direction, ClientData *handlePtr); -static int ZipChannelRead(ClientData instanceData, char *buf, +static int ZipChannelGetFile(void *instanceData, + int direction, void **handlePtr); +static int ZipChannelRead(void *instanceData, char *buf, int toRead, int *errloc); -static int ZipChannelSeek(ClientData instanceData, long offset, +static int ZipChannelSeek(void *instanceData, long offset, int mode, int *errloc); -static void ZipChannelWatchChannel(ClientData instanceData, +static void ZipChannelWatchChannel(void *instanceData, int mask); -static int ZipChannelWrite(ClientData instanceData, +static int ZipChannelWrite(void *instanceData, const char *buf, int toWrite, int *errloc); /* @@ -1094,7 +1094,7 @@ ZipFSOpenArchive( ZipFile *zf) { size_t i; - ClientData handle; + void *handle; zf->nameLength = 0; zf->isMemBuffer = 0; @@ -1867,7 +1867,7 @@ TclZipfs_Unmount( static int ZipFSMountObjCmd( - ClientData clientData, /* Not used. */ + void *clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -1901,7 +1901,7 @@ ZipFSMountObjCmd( static int ZipFSMountBufferObjCmd( - ClientData clientData, /* Not used. */ + void *clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -1953,7 +1953,7 @@ ZipFSMountBufferObjCmd( static int ZipFSRootObjCmd( - ClientData clientData, /* Not used. */ + void *clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -1980,7 +1980,7 @@ ZipFSRootObjCmd( static int ZipFSUnmountObjCmd( - ClientData clientData, /* Not used. */ + void *clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -2011,7 +2011,7 @@ ZipFSUnmountObjCmd( static int ZipFSMkKeyObjCmd( - ClientData clientData, /* Not used. */ + void *clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -2790,7 +2790,7 @@ ZipFSMkZipOrImgObjCmd( static int ZipFSMkZipObjCmd( - ClientData clientData, /* Not used. */ + void *clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -2810,7 +2810,7 @@ ZipFSMkZipObjCmd( static int ZipFSLMkZipObjCmd( - ClientData clientData, /* Not used. */ + void *clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -2847,7 +2847,7 @@ ZipFSLMkZipObjCmd( static int ZipFSMkImgObjCmd( - ClientData clientData, /* Not used. */ + void *clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -2868,7 +2868,7 @@ ZipFSMkImgObjCmd( static int ZipFSLMkImgObjCmd( - ClientData clientData, /* Not used. */ + void *clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -2905,7 +2905,7 @@ ZipFSLMkImgObjCmd( static int ZipFSCanonicalObjCmd( - ClientData clientData, /* Not used. */ + void *clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -2961,7 +2961,7 @@ ZipFSCanonicalObjCmd( static int ZipFSExistsObjCmd( - ClientData clientData, /* Not used. */ + void *clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -3014,7 +3014,7 @@ ZipFSExistsObjCmd( static int ZipFSInfoObjCmd( - ClientData clientData, /* Not used. */ + void *clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -3064,7 +3064,7 @@ ZipFSInfoObjCmd( static int ZipFSListObjCmd( - ClientData clientData, /* Not used. */ + void *clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -3279,7 +3279,7 @@ TclZipfs_TclLibrary(void) static int ZipFSTclLibraryObjCmd( - ClientData clientData, /* Not used. */ + void *clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -3313,7 +3313,7 @@ ZipFSTclLibraryObjCmd( static int ZipChannelClose( - ClientData instanceData, + void *instanceData, Tcl_Interp *interp) /* Current interpreter. */ { ZipChannel *info = instanceData; @@ -3371,7 +3371,7 @@ ZipChannelClose( static int ZipChannelRead( - ClientData instanceData, + void *instanceData, char *buf, int toRead, int *errloc) @@ -3444,7 +3444,7 @@ ZipChannelRead( static int ZipChannelWrite( - ClientData instanceData, + void *instanceData, const char *buf, int toWrite, int *errloc) @@ -3491,7 +3491,7 @@ ZipChannelWrite( static int ZipChannelSeek( - ClientData instanceData, + void *instanceData, long offset, int mode, int *errloc) @@ -3563,7 +3563,7 @@ ZipChannelSeek( static void ZipChannelWatchChannel( - ClientData instanceData, + void *instanceData, int mask) { return; @@ -3588,9 +3588,9 @@ ZipChannelWatchChannel( static int ZipChannelGetFile( - ClientData instanceData, + void *instanceData, int direction, - ClientData *handlePtr) + void **handlePtr) { return TCL_ERROR; } @@ -4335,7 +4335,7 @@ ZipFSMatchInDirectoryProc( static int ZipFSPathInFilesystemProc( Tcl_Obj *pathPtr, - ClientData *clientDataPtr) + void **clientDataPtr) { Tcl_HashEntry *hPtr; Tcl_HashSearch search; diff --git a/generic/tclZlib.c b/generic/tclZlib.c index d4a8ecb..1f20d5f 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -196,7 +196,7 @@ static void ZlibStreamCleanup(ZlibStreamHandle *zshPtr); static int ZlibStreamSubcmd(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static inline void ZlibTransformEventTimerKill(ZlibChannelData *cd); -static void ZlibTransformTimerRun(ClientData clientData); +static void ZlibTransformTimerRun(void *clientData); /* * Type of zlib-based compressing and decompressing channels. @@ -882,7 +882,7 @@ Tcl_ZlibStreamInit( static void ZlibStreamCmdDelete( - ClientData cd) + void *cd) { ZlibStreamHandle *zshPtr = cd; @@ -1918,7 +1918,7 @@ Tcl_ZlibAdler32( static int ZlibCmd( - ClientData notUsed, + void *notUsed, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -2514,7 +2514,7 @@ ZlibPushSubcmd( static int ZlibStreamCmd( - ClientData cd, + void *cd, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -2640,7 +2640,7 @@ ZlibStreamCmd( static int ZlibStreamAddCmd( - ClientData cd, + void *cd, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -2764,7 +2764,7 @@ ZlibStreamAddCmd( static int ZlibStreamPutCmd( - ClientData cd, + void *cd, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -2853,7 +2853,7 @@ ZlibStreamPutCmd( static int ZlibStreamHeaderCmd( - ClientData cd, + void *cd, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -2892,7 +2892,7 @@ ZlibStreamHeaderCmd( static int ZlibTransformClose( - ClientData instanceData, + void *instanceData, Tcl_Interp *interp) { ZlibChannelData *cd = instanceData; @@ -2983,7 +2983,7 @@ ZlibTransformClose( static int ZlibTransformInput( - ClientData instanceData, + void *instanceData, char *buf, int toRead, int *errorCodePtr) @@ -3097,7 +3097,7 @@ ZlibTransformInput( static int ZlibTransformOutput( - ClientData instanceData, + void *instanceData, const char *buf, int toWrite, int *errorCodePtr) @@ -3218,7 +3218,7 @@ ZlibTransformFlush( static int ZlibTransformSetOption( /* not used */ - ClientData instanceData, + void *instanceData, Tcl_Interp *interp, const char *optionName, const char *value) @@ -3331,7 +3331,7 @@ ZlibTransformSetOption( /* not used */ static int ZlibTransformGetOption( - ClientData instanceData, + void *instanceData, Tcl_Interp *interp, const char *optionName, Tcl_DString *dsPtr) @@ -3451,7 +3451,7 @@ ZlibTransformGetOption( static void ZlibTransformWatch( - ClientData instanceData, + void *instanceData, int mask) { ZlibChannelData *cd = instanceData; @@ -3474,7 +3474,7 @@ ZlibTransformWatch( static int ZlibTransformEventHandler( - ClientData instanceData, + void *instanceData, int interestMask) { ZlibChannelData *cd = instanceData; @@ -3495,7 +3495,7 @@ ZlibTransformEventTimerKill( static void ZlibTransformTimerRun( - ClientData clientData) + void *clientData) { ZlibChannelData *cd = clientData; @@ -3516,9 +3516,9 @@ ZlibTransformTimerRun( static int ZlibTransformGetHandle( - ClientData instanceData, + void *instanceData, int direction, - ClientData *handlePtr) + void **handlePtr) { ZlibChannelData *cd = instanceData; @@ -3537,7 +3537,7 @@ ZlibTransformGetHandle( static int ZlibTransformBlockMode( - ClientData instanceData, + void *instanceData, int mode) { ZlibChannelData *cd = instanceData; -- cgit v0.12 From dca8be01de6f8cc44135c0528bba0fc4d25c3a44 Mon Sep 17 00:00:00 2001 From: sebres Date: Thu, 15 Nov 2018 22:18:29 +0000 Subject: test cases for decode base64, bug [00d04c4f12], unfulfilled base64 (strict and non-strict mode, etc). --- tests/binary.test | 40 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 40 insertions(+) diff --git a/tests/binary.test b/tests/binary.test index 2a306a3..8c1dedb 100644 --- a/tests/binary.test +++ b/tests/binary.test @@ -2711,6 +2711,46 @@ test binary-73.30 {binary decode base64} -body { test binary-73.31 {binary decode base64} -body { list [string length [set r [binary decode base64 WA==WFla]]] $r } -returnCodes error -match glob -result {invalid base64 character *} +test binary-73.32 {binary decode base64, bug [00d04c4f12]} -body { + list \ + [string length [binary decode base64 =]] \ + [string length [binary decode base64 " ="]] \ + [string length [binary decode base64 " ="]] \ + [string length [binary decode base64 "\r\n\t="]] \ +} -result [lrepeat 4 0] +test binary-73.33 {binary decode base64, bug [00d04c4f12]} -body { + list \ + [string length [binary decode base64 ==]] \ + [string length [binary decode base64 " =="]] \ + [string length [binary decode base64 " =="]] \ + [string length [binary decode base64 " =="]] \ +} -result [lrepeat 4 0] +test binary-73.34 {binary decode base64, (compatibility) unfulfilled base64 (single char) in non-strict mode} -body { + list \ + [expr {[binary decode base64 a] eq [binary decode base64 ""]}] \ + [expr {[binary decode base64 abcda] eq [binary decode base64 "abcd"]}] +} -result [lrepeat 2 1] +test binary-73.35 {binary decode base64, bad base64 in strict mode} -body { + set r {} + foreach c {a " a" " a" " a" " a" abcda abcdabcda a= a== abcda= abcda==} { + lappend r \ + [catch {binary decode base64 $c}] \ + [catch {binary decode base64 -strict $c}] + } + set r +} -result [lrepeat 11 0 1] +test binary-73.36 {binary decode base64: check encoded & decoded equals original} -body { + set r {} + for {set i 0} {$i < 255 && [llength $r] < 20} {incr i} { + foreach c {1 2 3 4 5 6 7 8} { + set c [string repeat [format %c $i] $c] + if {[set a [binary decode base64 [set x [binary encode base64 $c]]]] ne $c} { + lappend r "encode & decode is wrong on string `$c` (encoded: $x): `$a` != `$c`" + } + } + } + join $r \n +} -result {} test binary-74.1 {binary encode uuencode} -body { binary encode uuencode -- cgit v0.12 From d1e5b0f72f8fd4f57590893488e6fd2df7fba2d2 Mon Sep 17 00:00:00 2001 From: sebres Date: Thu, 15 Nov 2018 22:31:39 +0000 Subject: fixes segfault [00d04c4f12], unfulfilled base64 (strict and non-strict mode, etc). --- generic/tclBinary.c | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index bb918f2..571eb07 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -2914,6 +2914,11 @@ BinaryDecode64( } else if (i > 1) { c = '='; } else { + if (strict && i <= 1) { + /* single resp. unfulfilled char (each 4th next single char) + * is rather bad64 error case in strict mode */ + goto bad64; + } cut += 3; break; } @@ -2944,9 +2949,11 @@ BinaryDecode64( value = (value << 6) | 0x3e; } else if (c == '/') { value = (value << 6) | 0x3f; - } else if (c == '=') { + } else if (c == '=' && ( + !strict || i > 1) /* "=" and "a=" is rather bad64 error case in strict mode */ + ) { value <<= 6; - cut++; + if (i) cut++; } else if (strict || !isspace(c)) { goto bad64; } else { -- cgit v0.12 From fa3d7ed1784d69d0aa90486a9f53ac71a0aa1c41 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 16 Nov 2018 13:45:26 +0000 Subject: Clear up a bunch of small issues found by Coverity analysis. --- generic/tclCmdMZ.c | 82 +++++++++++++++++++++++++-------------------------- generic/tclOOInfo.c | 14 +++++---- generic/tclOOMethod.c | 6 ++-- generic/tclPathObj.c | 1 + generic/tclZlib.c | 2 +- 5 files changed, 52 insertions(+), 53 deletions(-) diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 8530719..01c0a2d 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -1080,7 +1080,7 @@ Tcl_SplitObjCmd( Tcl_InitHashTable(&charReuseTable, TCL_ONE_WORD_KEYS); for ( ; stringPtr < end; stringPtr += len) { - int fullchar; + int fullchar; len = TclUtfToUniChar(stringPtr, &ch); fullchar = ch; @@ -2638,9 +2638,7 @@ StringEqualCmd( */ objv += objc-2; - - match = TclStringCmp (objv[0], objv[1], 0, nocase, reqlength); - + match = TclStringCmp(objv[0], objv[1], 0, nocase, reqlength); Tcl_SetObjResult(interp, Tcl_NewBooleanObj(match ? 0 : 1)); return TCL_OK; } @@ -2678,25 +2676,25 @@ StringCmpCmd( int match, nocase, reqlength, status; - if ((status = TclStringCmpOpts(interp, objc, objv, &nocase, &reqlength)) - != TCL_OK) { - + status = TclStringCmpOpts(interp, objc, objv, &nocase, &reqlength); + if (status != TCL_OK) { return status; } objv += objc-2; - match = TclStringCmp (objv[0], objv[1], 0, nocase, reqlength); + match = TclStringCmp(objv[0], objv[1], 0, nocase, reqlength); Tcl_SetObjResult(interp, Tcl_NewIntObj(match)); return TCL_OK; } -int TclStringCmp ( - Tcl_Obj *value1Ptr, - Tcl_Obj *value2Ptr, - int checkEq, /* comparison is only for equality */ - int nocase, /* comparison is not case sensitive */ - int reqlength /* requested length */ -) { +int +TclStringCmp( + Tcl_Obj *value1Ptr, + Tcl_Obj *value2Ptr, + int checkEq, /* comparison is only for equality */ + int nocase, /* comparison is not case sensitive */ + int reqlength) /* requested length */ +{ char *s1, *s2; int empty, length, match, s1len, s2len; memCmpFn_t memCmpFn; @@ -2707,7 +2705,6 @@ int TclStringCmp ( */ match = 0; } else { - if (!nocase && TclIsPureByteArray(value1Ptr) && TclIsPureByteArray(value2Ptr)) { /* @@ -2716,6 +2713,7 @@ int TclStringCmp ( * case-sensitive (which is all that really makes sense with byte * arrays anyway, and we have no memcasecmp() for some reason... :^) */ + s1 = (char *) Tcl_GetByteArrayFromObj(value1Ptr, &s1len); s2 = (char *) Tcl_GetByteArrayFromObj(value2Ptr, &s2len); memCmpFn = memcmp; @@ -2747,11 +2745,11 @@ int TclStringCmp ( s2 = (char *) Tcl_GetUnicode(value2Ptr); if ( #ifdef WORDS_BIGENDIAN - 1 + 1 #else - checkEq -#endif - ) { + checkEq +#endif /* WORDS_BIGENDIAN */ + ) { memCmpFn = memcmp; s1len *= sizeof(Tcl_UniChar); s2len *= sizeof(Tcl_UniChar); @@ -2761,33 +2759,34 @@ int TclStringCmp ( } } } else { - if ((empty = TclCheckEmptyString(value1Ptr)) > 0) { + empty = TclCheckEmptyString(value1Ptr); + if (empty > 0) { switch (TclCheckEmptyString(value2Ptr)) { - case -1: + case -1: s1 = ""; s1len = 0; s2 = TclGetStringFromObj(value2Ptr, &s2len); break; - case 0: + case 0: match = -1; goto matchdone; - case 1: - default: /* avoid warn: `s2` may be used uninitialized */ + case 1: + default: /* avoid warn: `s2` may be used uninitialized */ match = 0; goto matchdone; } } else if (TclCheckEmptyString(value2Ptr) > 0) { switch (empty) { - case -1: + case -1: s2 = ""; s2len = 0; s1 = TclGetStringFromObj(value1Ptr, &s1len); break; - case 0: + case 0: match = 1; goto matchdone; - case 1: - default: /* avoid warn: `s1` may be used uninitialized */ + case 1: + default: /* avoid warn: `s1` may be used uninitialized */ match = 0; goto matchdone; } @@ -2797,18 +2796,18 @@ int TclStringCmp ( } if (!nocase && checkEq) { /* - * When we have equal-length we can check only for (in)equality. - * We can use memcmp in all (n)eq cases because we - * don't need to worry about lexical LE/BE variance. + * When we have equal-length we can check only for + * (in)equality. We can use memcmp in all (n)eq cases because + * we don't need to worry about lexical LE/BE variance. */ memCmpFn = memcmp; } else { - /* - * As a catch-all we will work with UTF-8. We cannot use memcmp() as - * that is unsafe with any string containing NUL (\xC0\x80 in Tcl's - * utf rep). We can use the more efficient TclpUtfNcmp2 if we are - * case-sensitive and no specific length was requested. + * As a catch-all we will work with UTF-8. We cannot use + * memcmp() as that is unsafe with any string containing NUL + * (\xC0\x80 in Tcl's utf rep). We can use the more efficient + * TclpUtfNcmp2 if we are case-sensitive and no specific + * length was requested. */ if ((reqlength < 0) && !nocase) { @@ -2826,8 +2825,8 @@ int TclStringCmp ( length = reqlength; } else if (reqlength < 0) { /* - * The requested length is negative, so we ignore it by setting it to - * length + 1 so we correct the match var. + * The requested length is negative, so we ignore it by setting it + * to length + 1 so we correct the match var. */ reqlength = length + 1; @@ -2851,13 +2850,12 @@ int TclStringCmp ( return match; } -int TclStringCmpOpts ( +int TclStringCmpOpts( Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[], /* Argument objects. */ int *nocase, - int *reqlength -) + int *reqlength) { int i, length; const char *string; diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c index 76eaef5..c9263b5 100644 --- a/generic/tclOOInfo.c +++ b/generic/tclOOInfo.c @@ -114,12 +114,14 @@ TclOOInitInfo( */ infoCmd = Tcl_FindCommand(interp, "info", NULL, TCL_GLOBAL_ONLY); - Tcl_GetEnsembleMappingDict(NULL, infoCmd, &mapDict); - Tcl_DictObjPut(NULL, mapDict, Tcl_NewStringObj("object", -1), - Tcl_NewStringObj("::oo::InfoObject", -1)); - Tcl_DictObjPut(NULL, mapDict, Tcl_NewStringObj("class", -1), - Tcl_NewStringObj("::oo::InfoClass", -1)); - Tcl_SetEnsembleMappingDict(interp, infoCmd, mapDict); + if (infoCmd) { + Tcl_GetEnsembleMappingDict(NULL, infoCmd, &mapDict); + Tcl_DictObjPut(NULL, mapDict, Tcl_NewStringObj("object", -1), + Tcl_NewStringObj("::oo::InfoObject", -1)); + Tcl_DictObjPut(NULL, mapDict, Tcl_NewStringObj("class", -1), + Tcl_NewStringObj("::oo::InfoClass", -1)); + Tcl_SetEnsembleMappingDict(interp, infoCmd, mapDict); + } } /* diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index 8da0fb3..3e64ba2 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -970,10 +970,8 @@ ProcedureMethodVarResolver( * Must not retain reference to resolved information. [Bug 3105999] */ - if (rPtr != NULL) { - rPtr->deleteProc(rPtr); - } - return (*varPtr? TCL_OK : TCL_CONTINUE); + rPtr->deleteProc(rPtr); + return (*varPtr ? TCL_OK : TCL_CONTINUE); } static Tcl_Var diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index 29d6f96..e214d1f 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -1359,6 +1359,7 @@ TclNewFSPathObj( count = 0; state = 1; } + break; case 1: /* Scanning for next dirsep */ switch (*p) { case '/': diff --git a/generic/tclZlib.c b/generic/tclZlib.c index fc20d7e..aed38c3 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -1488,7 +1488,7 @@ Tcl_ZlibStreamGet( count = 0; for (i=0; ioutData, i, &itemObj); - itemPtr = Tcl_GetByteArrayFromObj(itemObj, &itemLen); + (void) Tcl_GetByteArrayFromObj(itemObj, &itemLen); if (i == 0) { count += itemLen - zshPtr->outPos; } else { -- cgit v0.12 From 38f743a2c7279a2cc77c9da36499a9d43a7427e0 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 16 Nov 2018 18:45:59 +0000 Subject: [00d04c4f12] Repair broken edge cases in [binary encode base64]. --- changes | 2 ++ generic/tclBinary.c | 11 +++++++++-- tests/binary.test | 40 ++++++++++++++++++++++++++++++++++++++++ 3 files changed, 51 insertions(+), 2 deletions(-) diff --git a/changes b/changes index 1bae43b..eb18c72 100644 --- a/changes +++ b/changes @@ -8891,4 +8891,6 @@ improvements to regexp engine from Postgres (lane,porter,fellows,seltenreich) 2018-11-09 (bug)[35a8f1] overlong string length of some lists (owens) +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/ - diff --git a/generic/tclBinary.c b/generic/tclBinary.c index bb918f2..571eb07 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -2914,6 +2914,11 @@ BinaryDecode64( } else if (i > 1) { c = '='; } else { + if (strict && i <= 1) { + /* single resp. unfulfilled char (each 4th next single char) + * is rather bad64 error case in strict mode */ + goto bad64; + } cut += 3; break; } @@ -2944,9 +2949,11 @@ BinaryDecode64( value = (value << 6) | 0x3e; } else if (c == '/') { value = (value << 6) | 0x3f; - } else if (c == '=') { + } else if (c == '=' && ( + !strict || i > 1) /* "=" and "a=" is rather bad64 error case in strict mode */ + ) { value <<= 6; - cut++; + if (i) cut++; } else if (strict || !isspace(c)) { goto bad64; } else { diff --git a/tests/binary.test b/tests/binary.test index 2a306a3..8c1dedb 100644 --- a/tests/binary.test +++ b/tests/binary.test @@ -2711,6 +2711,46 @@ test binary-73.30 {binary decode base64} -body { test binary-73.31 {binary decode base64} -body { list [string length [set r [binary decode base64 WA==WFla]]] $r } -returnCodes error -match glob -result {invalid base64 character *} +test binary-73.32 {binary decode base64, bug [00d04c4f12]} -body { + list \ + [string length [binary decode base64 =]] \ + [string length [binary decode base64 " ="]] \ + [string length [binary decode base64 " ="]] \ + [string length [binary decode base64 "\r\n\t="]] \ +} -result [lrepeat 4 0] +test binary-73.33 {binary decode base64, bug [00d04c4f12]} -body { + list \ + [string length [binary decode base64 ==]] \ + [string length [binary decode base64 " =="]] \ + [string length [binary decode base64 " =="]] \ + [string length [binary decode base64 " =="]] \ +} -result [lrepeat 4 0] +test binary-73.34 {binary decode base64, (compatibility) unfulfilled base64 (single char) in non-strict mode} -body { + list \ + [expr {[binary decode base64 a] eq [binary decode base64 ""]}] \ + [expr {[binary decode base64 abcda] eq [binary decode base64 "abcd"]}] +} -result [lrepeat 2 1] +test binary-73.35 {binary decode base64, bad base64 in strict mode} -body { + set r {} + foreach c {a " a" " a" " a" " a" abcda abcdabcda a= a== abcda= abcda==} { + lappend r \ + [catch {binary decode base64 $c}] \ + [catch {binary decode base64 -strict $c}] + } + set r +} -result [lrepeat 11 0 1] +test binary-73.36 {binary decode base64: check encoded & decoded equals original} -body { + set r {} + for {set i 0} {$i < 255 && [llength $r] < 20} {incr i} { + foreach c {1 2 3 4 5 6 7 8} { + set c [string repeat [format %c $i] $c] + if {[set a [binary decode base64 [set x [binary encode base64 $c]]]] ne $c} { + lappend r "encode & decode is wrong on string `$c` (encoded: $x): `$a` != `$c`" + } + } + } + join $r \n +} -result {} test binary-74.1 {binary encode uuencode} -body { binary encode uuencode -- cgit v0.12