summaryrefslogtreecommitdiffstats
path: root/tests
diff options
context:
space:
mode:
Diffstat (limited to 'tests')
-rw-r--r--tests/binary.test12
-rw-r--r--tests/chanio.test6
-rw-r--r--tests/clock.test40
-rw-r--r--tests/cmdAH.test4
-rw-r--r--tests/coroutine.test39
-rw-r--r--tests/fileName.test3
-rw-r--r--tests/fileSystem.test10
-rw-r--r--tests/format.test67
-rw-r--r--tests/http.test16
-rw-r--r--tests/httpd7
-rw-r--r--tests/httpold.test6
-rw-r--r--tests/interp.test4
-rw-r--r--tests/io.test4
-rw-r--r--tests/link.test2
-rw-r--r--tests/load.test25
-rw-r--r--tests/oo.test38
-rw-r--r--tests/scan.test18
-rw-r--r--tests/socket.test41
-rw-r--r--tests/util.test32
-rw-r--r--tests/zlib.test16
20 files changed, 323 insertions, 67 deletions
diff --git a/tests/binary.test b/tests/binary.test
index 7738f69..1ee815b 100644
--- a/tests/binary.test
+++ b/tests/binary.test
@@ -1506,6 +1506,18 @@ test binary-37.9 {GetFormatSpec: numbers} {
binary scan $x f* bla
set bla
} {1.0 -1.0 2.0 -2.0 0.0}
+test binary-37.10 {GetFormatSpec: count overflow} {
+ binary scan x a[format %ld 0x7fffffff] r
+} 0
+test binary-37.11 {GetFormatSpec: count overflow} {
+ binary scan x a[format %ld 0x10000000] r
+} 0
+test binary-37.12 {GetFormatSpec: count overflow} {
+ binary scan x a[format %ld 0x100000000] r
+} 0
+test binary-37.13 {GetFormatSpec: count overflow} {
+ binary scan x a[format %lld 0x10000000000000000] r
+} 0
test binary-38.1 {FormatNumber: word alignment} {
set x [binary format c1s1 1 1]
diff --git a/tests/chanio.test b/tests/chanio.test
index 8e27af9..8c74566 100644
--- a/tests/chanio.test
+++ b/tests/chanio.test
@@ -5338,7 +5338,7 @@ test chan-io-40.2 {POSIX open access modes: CREAT} -setup {
} -constraints {unix} -body {
set f [open $path(test3) {WRONLY CREAT} 0600]
file stat $path(test3) stats
- set x [format "0%o" [expr $stats(mode)&0o777]]
+ set x [format "%#o" [expr $stats(mode)&0o777]]
chan puts $f "line 1"
chan close $f
set f [open $path(test3) r]
@@ -5352,8 +5352,8 @@ test chan-io-40.3 {POSIX open access modes: CREAT} -setup {
# This test only works if your umask is 2, like ouster's.
chan close [open $path(test3) {WRONLY CREAT}]
file stat $path(test3) stats
- format "0%o" [expr $stats(mode)&0o777]
-} -result [format %04o [expr {0o666 & ~ $umaskValue}]]
+ format "%#o" [expr $stats(mode)&0o777]
+} -result [format %#4o [expr {0o666 & ~ $umaskValue}]]
test chan-io-40.4 {POSIX open access modes: CREAT} -setup {
file delete $path(test3)
} -body {
diff --git a/tests/clock.test b/tests/clock.test
index 9e86c97..af517c8 100644
--- a/tests/clock.test
+++ b/tests/clock.test
@@ -35,6 +35,9 @@ testConstraint y2038 \
# TEST PLAN
+# clock-0:
+# several base test-cases
+#
# clock-1:
# [clock format] - tests of bad and empty arguments
#
@@ -251,12 +254,34 @@ proc ::testClock::registry { cmd path key } {
return [dict get $reg $path $key]
}
+# Base test cases:
+
+test clock-0.1 "initial: auto-loading of ensemble and stubs on demand" {
+ set i [interp create]; # because clock can be used somewhere, test it in new interp:
+
+ set ret [$i eval {
+
+ lappend ret ens:[namespace ensemble exists ::clock]
+ clock seconds; # init ensemble (but not yet stubs, loading of clock.tcl retarded)
+ lappend ret ens:[namespace ensemble exists ::clock]
+ lappend ret stubs:[expr {[namespace which -command ::tcl::clock::GetSystemTimeZone] ne ""}]
+ clock format -now; # clock.tcl stubs expected
+ lappend ret stubs:[expr {[namespace which -command ::tcl::clock::GetSystemTimeZone] ne ""}]
+ }]
+ interp delete $i
+ set ret
+} {ens:0 ens:1 stubs:0 stubs:1}
+
# Test some of the basics of [clock format]
test clock-1.0 "clock format - wrong # args" {
list [catch {clock format} msg] $msg $::errorCode
} {1 {wrong # args: should be "clock format clockval|-now ?-format string? ?-gmt boolean? ?-locale LOCALE? ?-timezone ZONE?"} {CLOCK wrongNumArgs}}
+test clock-1.0.1 "clock format - wrong # args (compiled ensemble with invalid syntax)" {
+ list [catch {clock format 0 -too-few-options-4-test} msg] $msg $::errorCode
+} {1 {wrong # args: should be "clock format clockval|-now ?-format string? ?-gmt boolean? ?-locale LOCALE? ?-timezone ZONE?"} {CLOCK wrongNumArgs}}
+
test clock-1.1 "clock format - bad time" {
list [catch {clock format foo} msg] $msg
} {1 {expected integer but got "foo"}}
@@ -36187,7 +36212,7 @@ test clock-36.3 {clock scan next monthname} {
} "05.2001"
test clock-37.1 {%s gmt testing} {
- set s [clock seconds]
+ set s [clock scan "2017-05-10 09:00:00" -gmt 1]
set a [clock format $s -format %s -gmt 0]
set b [clock format $s -format %s -gmt 1]
set c [clock scan $s -format %s -gmt 0]
@@ -36196,8 +36221,8 @@ test clock-37.1 {%s gmt testing} {
# depend on the time zone.
list [expr {$b-$a}] [expr {$d-$c}]
} {0 0}
-test clock-37.2 {%Es gmt testing} {
- set s [clock seconds]
+test clock-37.2 {%Es gmt testing CET} {
+ set s [clock scan "2017-01-10 09:00:00" -gmt 1]
set a [clock format $s -format %Es -timezone CET]
set b [clock format $s -format %Es -gmt 1]
set c [clock scan $s -format %Es -timezone CET]
@@ -36205,6 +36230,15 @@ test clock-37.2 {%Es gmt testing} {
# %Es depend on the time zone (local seconds instead of posix seconds).
list [expr {$b-$a}] [expr {$d-$c}]
} {-3600 3600}
+test clock-37.3 {%Es gmt testing CEST} {
+ set s [clock scan "2017-05-10 09:00:00" -gmt 1]
+ set a [clock format $s -format %Es -timezone CET]
+ set b [clock format $s -format %Es -gmt 1]
+ set c [clock scan $s -format %Es -timezone CET]
+ set d [clock scan $s -format %Es -gmt 1]
+ # %Es depend on the time zone (local seconds instead of posix seconds).
+ list [expr {$b-$a}] [expr {$d-$c}]
+} {-7200 7200}
test clock-38.1 {regression - convertUTCToLocalViaC - east of Greenwich} \
-setup {
diff --git a/tests/cmdAH.test b/tests/cmdAH.test
index b4ef605..3c58c1b 100644
--- a/tests/cmdAH.test
+++ b/tests/cmdAH.test
@@ -167,10 +167,10 @@ test cmdAH-3.2 {Tcl_ContinueObjCmd, success} {
test cmdAH-4.1 {Tcl_EncodingObjCmd} -returnCodes error -body {
encoding
-} -result {wrong # args: should be "encoding option ?arg ...?"}
+} -result {wrong # args: should be "encoding subcommand ?arg ...?"}
test cmdAH-4.2 {Tcl_EncodingObjCmd} -returnCodes error -body {
encoding foo
-} -result {bad option "foo": must be convertfrom, convertto, dirs, names, or system}
+} -result {unknown or ambiguous subcommand "foo": must be convertfrom, convertto, dirs, names, or system}
test cmdAH-4.3 {Tcl_EncodingObjCmd} -returnCodes error -body {
encoding convertto
} -result {wrong # args: should be "encoding convertto ?encoding? data"}
diff --git a/tests/coroutine.test b/tests/coroutine.test
index 86fa6e3..07feb53 100644
--- a/tests/coroutine.test
+++ b/tests/coroutine.test
@@ -741,6 +741,45 @@ test coroutine-7.12 {coro floor above street level #3008307} -body {
list
} -result {}
+test coroutine-8.0.0 {coro inject executed} -body {
+ coroutine demo apply {{} { foreach i {1 2} yield }}
+ demo
+ set ::result none
+ tcl::unsupported::inject demo set ::result inject-executed
+ demo
+ set ::result
+} -result {inject-executed}
+test coroutine-8.0.1 {coro inject after error} -body {
+ coroutine demo apply {{} { foreach i {1 2} yield; error test }}
+ demo
+ set ::result none
+ tcl::unsupported::inject demo set ::result inject-executed
+ lappend ::result [catch {demo} err] $err
+} -result {inject-executed 1 test}
+test coroutine-8.1.1 {coro inject, ticket 42202ba1e5ff566e} -body {
+ interp create slave
+ slave eval {
+ coroutine demo apply {{} { while {1} yield }}
+ demo
+ tcl::unsupported::inject demo set ::result inject-executed
+ }
+ interp delete slave
+} -result {}
+test coroutine-8.1.2 {coro inject with result, ticket 42202ba1e5ff566e} -body {
+ interp create slave
+ slave eval {
+ coroutine demo apply {{} { while {1} yield }}
+ demo
+ tcl::unsupported::inject demo set ::result inject-executed
+ }
+ slave eval demo
+ set result [slave eval {set ::result}]
+
+ interp delete slave
+ set result
+} -result {inject-executed}
+
+
# cleanup
unset lambda
diff --git a/tests/fileName.test b/tests/fileName.test
index 387d844..ce89623 100644
--- a/tests/fileName.test
+++ b/tests/fileName.test
@@ -441,6 +441,9 @@ test filename-7.18 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
file join /// a b
} "/a/b"
+test filename-7.19 {[Bug f34cf83dd0]} {
+ file join foo //bar
+} /bar
test filename-9.1 {Tcl_JoinPath: win} {testsetplatform} {
testsetplatform win
diff --git a/tests/fileSystem.test b/tests/fileSystem.test
index 1941936..4c90376 100644
--- a/tests/fileSystem.test
+++ b/tests/fileSystem.test
@@ -367,6 +367,16 @@ test filesystem-1.51 {file normalisation .. beyond root (Bug 1379287)} {
test filesystem-1.51.1 {file normalisation .. beyond root (Bug 1379287)} {
testPathEqual [file norm /../../] [file norm /]
} ok
+test filesystem-1.52 {bug f9f390d0fa: file join where strep is not canonical} -constraints unix -body {
+ set x //foo
+ file normalize $x
+ file join $x bar
+} -result /foo/bar
+test filesystem-1.52.1 {bug f9f390d0fa: file join where strep is not canonical} -body {
+ set x //foo
+ file normalize $x
+ file join $x
+} -result /foo
test filesystem-2.0 {new native path} {unix} {
foreach f [lsort [glob -nocomplain /usr/bin/c*]] {
diff --git a/tests/format.test b/tests/format.test
index e199398..722ad21 100644
--- a/tests/format.test
+++ b/tests/format.test
@@ -21,6 +21,7 @@ testConstraint longIs64bit [expr {int(0x8000000000000000) < 0}]
testConstraint wideIs64bit \
[expr {(wide(0x80000000) > 0) && (wide(0x8000000000000000) < 0)}]
testConstraint wideBiggerThanInt [expr {wide(0x80000000) != int(0x80000000)}]
+testConstraint pointerIs64bit [expr {$tcl_platform(pointerSize) >= 8}]
test format-1.1 {integer formatting} {
format "%*d %d %d %d" 6 34 16923 -12 -1
@@ -52,32 +53,32 @@ test format-1.7.1 {integer formatting} longIs64bit {
format "%4x %4x %4x %4x" 6 34 16923 -12 -1
} { 6 22 421b fffffffffffffff4}
test format-1.8 {integer formatting} longIs32bit {
- format "%#x %#X %#X %#x" 6 34 16923 -12 -1
-} {0x6 0X22 0X421B 0xfffffff4}
+ format "%#x %#x %#X %#X %#x" 0 6 34 16923 -12 -1
+} {0x0 0x6 0X22 0X421B 0xfffffff4}
test format-1.8.1 {integer formatting} longIs64bit {
- format "%#x %#X %#X %#x" 6 34 16923 -12 -1
-} {0x6 0X22 0X421B 0xfffffffffffffff4}
+ format "%#x %#x %#X %#X %#x" 0 6 34 16923 -12 -1
+} {0x0 0x6 0X22 0X421B 0xfffffffffffffff4}
test format-1.9 {integer formatting} longIs32bit {
- format "%#20x %#20x %#20x %#20x" 6 34 16923 -12 -1
-} { 0x6 0x22 0x421b 0xfffffff4}
+ format "%#5x %#20x %#20x %#20x %#20x" 0 6 34 16923 -12 -1
+} { 0x0 0x6 0x22 0x421b 0xfffffff4}
test format-1.9.1 {integer formatting} longIs64bit {
- format "%#20x %#20x %#20x %#20x" 6 34 16923 -12 -1
-} { 0x6 0x22 0x421b 0xfffffffffffffff4}
+ format "%#5x %#20x %#20x %#20x %#20x" 0 6 34 16923 -12 -1
+} { 0x0 0x6 0x22 0x421b 0xfffffffffffffff4}
test format-1.10 {integer formatting} longIs32bit {
- format "%-#20x %-#20x %-#20x %-#20x" 6 34 16923 -12 -1
-} {0x6 0x22 0x421b 0xfffffff4 }
+ format "%-#5x %-#20x %-#20x %-#20x %-#20x" 0 6 34 16923 -12 -1
+} {0x0 0x6 0x22 0x421b 0xfffffff4 }
test format-1.10.1 {integer formatting} longIs64bit {
- format "%-#20x %-#20x %-#20x %-#20x" 6 34 16923 -12 -1
-} {0x6 0x22 0x421b 0xfffffffffffffff4 }
+ format "%-#5x %-#20x %-#20x %-#20x %-#20x" 0 6 34 16923 -12 -1
+} {0x0 0x6 0x22 0x421b 0xfffffffffffffff4 }
test format-1.11 {integer formatting} longIs32bit {
- format "%-#20o %#-20o %#-20o %#-20o" 6 34 16923 -12 -1
-} {06 042 041033 037777777764 }
+ format "%-#5o %-#20o %#-20o %#-20o %#-20o" 0 6 34 16923 -12 -1
+} {0 06 042 041033 037777777764 }
test format-1.11.1 {integer formatting} longIs64bit {
- format "%-#20o %#-20o %#-20o %#-20o" 6 34 16923 -12 -1
-} {06 042 041033 01777777777777777777764}
+ format "%-#5o %-#20o %#-20o %#-20o %#-20o" 0 6 34 16923 -12 -1
+} {0 06 042 041033 01777777777777777777764}
test format-1.12 {integer formatting} {
- format "%b %#b %llb" 5 5 [expr {2**100}]
-} {101 0b101 10000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000}
+ format "%b %#b %#b %llb" 5 0 5 [expr {2**100}]
+} {101 0b0 0b101 10000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000}
test format-2.1 {string formatting} {
format "%s %s %c %s" abcd {This is a very long test string.} 120 x
@@ -349,9 +350,9 @@ test format-8.19 {error conditions} {
catch {format %q x}
} 1
test format-8.20 {error conditions} {
- catch {format %q x} msg
+ catch {format %r x} msg
set msg
-} {bad field specifier "q"}
+} {bad field specifier "r"}
test format-8.21 {error conditions} {
catch {format %d}
} 1
@@ -363,6 +364,26 @@ test format-8.23 {error conditions} {
catch {format "%d %d" 24 xyz} msg
set msg
} {expected integer but got "xyz"}
+# Since "%zd" and "%td" are equivalent to "%lld" in 64-bit platforms and
+# equivalent to "%d" in 32-bit platforms, they are really not useful in
+# scripts, therefore they are not documented. It's intended use is through
+# the function Tcl_AppendPrintfToObj (et al).
+test format-8.24 {Undocumented formats} -body {
+ format "%zd %td %d" [expr 2**30] [expr 2**30] [expr 2**30]
+} -result {1073741824 1073741824 1073741824}
+test format-8.25 {Undocumented formats} -constraints pointerIs64bit -body {
+ format "%zd %td %lld" [expr 2**33] [expr 2**33] [expr 2**33]
+} -result {8589934592 8589934592 8589934592}
+# Since "%p" is equivalent to "%#llx" in 64-bit platforms and equivalent
+# to "%#x" in 32-bit platforms, it are really not useful in scripts,
+# therefore they are not documented. It's intended use is through the
+# function Tcl_AppendPrintfToObj (et al).
+test format-8.26 {Undocumented formats} -body {
+ format "%p %#x" [expr 2**31] [expr 2**31]
+} -result {0x80000000 0x80000000}
+test format-8.27 {Undocumented formats} -constraints pointerIs64bit -body {
+ format "%p %#llx" [expr 2**33] [expr 2**33]
+} -result {0x200000000 0x200000000}
test format-9.1 {long result} {
set a {1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ 1 2 3 4 5 6 7 8 9 0 a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z}
@@ -528,6 +549,12 @@ test format-17.3 {testing %ld with non-wide} {wideIs64bit} {
test format-17.4 {testing %l with non-integer} {
format %lf 1
} 1.000000
+test format-17.5 {testing %llu with positive bignum} -body {
+ format %llu 0xabcdef0123456789abcdef
+} -returnCodes 1 -result {unsigned bignum format is invalid}
+test format-17.6 {testing %llu with negative number} -body {
+ format %llu -1
+} -returnCodes 1 -result {unsigned bignum format is invalid}
test format-18.1 {do not demote existing numeric values} {
set a 0xaaaaaaaa
diff --git a/tests/http.test b/tests/http.test
index 12ad475..025c32e 100644
--- a/tests/http.test
+++ b/tests/http.test
@@ -36,7 +36,6 @@ proc bgerror {args} {
puts stderr $errorInfo
}
-set port 8010
set bindata "This is binary data\x0d\x0amore\x0dmore\x0amore\x00null"
catch {unset data}
@@ -55,9 +54,8 @@ catch {package require Thread 2.7-}
if {[catch {package present Thread}] == 0 && [file exists $httpdFile]} {
set httpthread [thread::create -preserved]
thread::send $httpthread [list source $httpdFile]
- thread::send $httpthread [list set port $port]
thread::send $httpthread [list set bindata $bindata]
- thread::send $httpthread {httpd_init $port}
+ thread::send $httpthread {httpd_init 0; set port} port
puts "Running httpd in thread $httpthread"
} else {
if {![file exists $httpdFile]} {
@@ -69,10 +67,8 @@ if {[catch {package present Thread}] == 0 && [file exists $httpdFile]} {
# Let the OS pick the port; that's much more flexible
if {[catch {httpd_init 0} listen]} {
puts "Cannot start http server, http test skipped"
- unset port
+ catch {unset port}
return
- } else {
- set port [lindex [fconfigure $listen -sockname] 2]
}
}
@@ -592,6 +588,14 @@ test http-4.15 {http::Event} -body {
} -cleanup {
catch {http::cleanup $token}
} -returnCodes 1 -match glob -result "couldn't open socket*"
+test http-1.15 {Leak with Close vs Keepalive (bug [6ca52aec14]} -body {
+ set before [chan names]
+ set token [http::geturl $url -headers {X-Connection keep-alive}]
+ http::cleanup $token
+ update
+ set after [chan names]
+ expr {$before eq $after}
+} -result 1
test http-5.1 {http::formatQuery} {
http::formatQuery name1 value1 name2 "value two"
diff --git a/tests/httpd b/tests/httpd
index 40e10df..f15d71b 100644
--- a/tests/httpd
+++ b/tests/httpd
@@ -11,7 +11,12 @@
#set httpLog 1
proc httpd_init {{port 8015}} {
- socket -server httpdAccept $port
+ set s [socket -server httpdAccept $port]
+ # Save the actual port number in a global variable.
+ # This is important when we're called with port 0
+ # for picking an unused port at random.
+ set ::port [lindex [chan configure $s -sockname] 2]
+ return $s
}
proc httpd_log {args} {
global httpLog
diff --git a/tests/httpold.test b/tests/httpold.test
index 5995bed..ab26613 100644
--- a/tests/httpold.test
+++ b/tests/httpold.test
@@ -1,3 +1,4 @@
+# -*- tcl -*-
# Commands covered: http_config, http_get, http_wait, http_reset
#
# This file contains a collection of tests for the http script library.
@@ -41,10 +42,9 @@ catch {unset data}
##
source [file join [file dirname [info script]] httpd]
-set port 8010
-if [catch {httpd_init $port} listen] {
+if [catch {httpd_init 0} listen] {
puts "Cannot start http server, http test skipped"
- unset port
+ catch {unset port}
::tcltest::cleanupTests
return
}
diff --git a/tests/interp.test b/tests/interp.test
index ed76f1a..1389304 100644
--- a/tests/interp.test
+++ b/tests/interp.test
@@ -20,7 +20,7 @@ catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testinterpdelete [llength [info commands testinterpdelete]]
-set hidden_cmds {cd encoding exec exit fconfigure file glob load open pwd socket source tcl:file:atime tcl:file:attributes tcl:file:copy tcl:file:delete tcl:file:dirname tcl:file:executable tcl:file:exists tcl:file:extension tcl:file:isdirectory tcl:file:isfile tcl:file:link tcl:file:lstat tcl:file:mkdir tcl:file:mtime tcl:file:nativename tcl:file:normalize tcl:file:owned tcl:file:readable tcl:file:readlink tcl:file:rename tcl:file:rootname tcl:file:size tcl:file:stat tcl:file:tail tcl:file:tempfile tcl:file:type tcl:file:volumes tcl:file:writable unload}
+set hidden_cmds {cd encoding exec exit fconfigure file glob load open pwd socket source tcl:encoding:dirs tcl:file:atime tcl:file:attributes tcl:file:copy tcl:file:delete tcl:file:dirname tcl:file:executable tcl:file:exists tcl:file:extension tcl:file:isdirectory tcl:file:isfile tcl:file:link tcl:file:lstat tcl:file:mkdir tcl:file:mtime tcl:file:nativename tcl:file:normalize tcl:file:owned tcl:file:readable tcl:file:readlink tcl:file:rename tcl:file:rootname tcl:file:size tcl:file:stat tcl:file:tail tcl:file:tempfile tcl:file:type tcl:file:volumes tcl:file:writable unload}
foreach i [interp slaves] {
interp delete $i
@@ -615,6 +615,8 @@ test interp-14.11 {{interp alias} {target named the empty string} {bug 2bf56185}
} -body {
interp alias {} p1 $interp {}
p1 one two three
+} -cleanup {
+ interp delete $interp
} -result {one two three}
# part 15: testing file sharing
diff --git a/tests/io.test b/tests/io.test
index 6e7420d..3fc370d 100644
--- a/tests/io.test
+++ b/tests/io.test
@@ -5652,8 +5652,8 @@ test io-40.3 {POSIX open access modes: CREAT} {unix umask} {
set f [open $path(test3) {WRONLY CREAT}]
close $f
file stat $path(test3) stats
- format "0%o" [expr $stats(mode)&0o777]
-} [format %04o [expr {0o666 & ~ $umaskValue}]]
+ format "%#o" [expr $stats(mode)&0o777]
+} [format %#4o [expr {0o666 & ~ $umaskValue}]]
test io-40.4 {POSIX open access modes: CREAT} {
file delete $path(test3)
set f [open $path(test3) w]
diff --git a/tests/link.test b/tests/link.test
index dda7d6b..6bff356 100644
--- a/tests/link.test
+++ b/tests/link.test
@@ -152,7 +152,7 @@ test link-2.8 {writing C variables from Tcl} -constraints {testlink} -setup {
set uwide "0O"
concat [testlink get] | $int $real $bool $string $wide $char $uchar $short $ushort $uint $long $ulong $float $uwide
} -result {0 0.0 0 0 0 0 0 0 0 0 0 0 0.0 0 | 0x 0b 0 0 0O 0X 0B 0O 0x 0b 0o 0X 0B 0O}
-test link-2.8 {writing C variables from Tcl} -constraints {testlink} -setup {
+test link-2.9 {writing C variables from Tcl} -constraints {testlink} -setup {
testlink delete
} -body {
testlink set 43 1.21 4 - 56785678 64 250 30000 60000 0xbaadbeef 12321 32123 3.25 1231231234
diff --git a/tests/load.test b/tests/load.test
index 7c4b47f..4cd1fcd 100644
--- a/tests/load.test
+++ b/tests/load.test
@@ -185,23 +185,30 @@ test load-7.4 {Tcl_StaticPackage procedure, redundant calls} -setup {
info loaded
} -result [list {{} Double} {{} More} {{} Another} {{} Test} {*}$currentRealPackages {*}$alreadyTotalLoaded]
-teststaticpkg Test 1 1
-teststaticpkg Another 0 1
-teststaticpkg More 0 1
-teststaticpkg Double 0 1
-test load-8.1 {TclGetLoadedPackages procedure} [list teststaticpkg $dll $loaded] {
+testConstraint teststaticpkg_8.x \
+ [if {[testConstraint teststaticpkg]} {
+ teststaticpkg Test 1 1
+ teststaticpkg Another 0 1
+ teststaticpkg More 0 1
+ teststaticpkg Double 0 1
+ expr 1
+ } else {
+ expr 0
+ }]
+
+test load-8.1 {TclGetLoadedPackages procedure} [list teststaticpkg_8.x $dll $loaded] {
lsort -index 1 [info loaded]
} [lsort -index 1 [list {{} Double} {{} More} {{} Another} {{} Test} {*}$currentRealPackages {*}$alreadyTotalLoaded]]
-test load-8.2 {TclGetLoadedPackages procedure} -body {
+test load-8.2 {TclGetLoadedPackages procedure} -constraints {teststaticpkg_8.x} -body {
info loaded gorp
} -returnCodes error -result {could not find interpreter "gorp"}
-test load-8.3a {TclGetLoadedPackages procedure} [list teststaticpkg $dll $loaded] {
+test load-8.3a {TclGetLoadedPackages procedure} [list teststaticpkg_8.x $dll $loaded] {
lsort -index 1 [info loaded {}]
} [lsort -index 1 [list {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga] [list [file join $testDir pkgb$ext] Pkgb] {*}$alreadyLoaded]]
-test load-8.3b {TclGetLoadedPackages procedure} [list teststaticpkg $dll $loaded] {
+test load-8.3b {TclGetLoadedPackages procedure} [list teststaticpkg_8.x $dll $loaded] {
lsort -index 1 [info loaded child]
} [lsort -index 1 [list {{} Test} [list [file join $testDir pkgb$ext] Pkgb]]]
-test load-8.4 {TclGetLoadedPackages procedure} [list $dll $loaded teststaticpkg] {
+test load-8.4 {TclGetLoadedPackages procedure} [list teststaticpkg_8.x $dll $loaded] {
load [file join $testDir pkgb$ext] pkgb
list [lsort -index 1 [info loaded {}]] [lsort [info commands pkgb_*]]
} [list [lsort -index 1 [concat [list [list [file join $testDir pkgb$ext] Pkgb] {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga]] $alreadyLoaded]] {pkgb_demo pkgb_sub pkgb_unsafe}]
diff --git a/tests/oo.test b/tests/oo.test
index ccb05c1..e03911b 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -2241,6 +2241,44 @@ test oo-17.10 {OO: class introspection} -setup {
oo::define foo unexport {*}[info class methods foo -all]
info class methods foo -all
} -result {}
+set stdmethods {<cloned> destroy eval unknown variable varname}
+test oo-17.11 {OO: object method unexport (bug 900cb0284bc)} -setup {
+ oo::object create o
+ oo::objdefine o unexport m
+} -body {
+ lsort [info object methods o -all -private]
+} -cleanup {
+ o destroy
+} -result $stdmethods
+test oo-17.12 {OO: instance method unexport (bug 900cb0284bc)} -setup {
+ oo::class create c
+ c create o
+ oo::objdefine o unexport m
+} -body {
+ lsort [info object methods o -all -private]
+} -cleanup {
+ o destroy
+ c destroy
+} -result $stdmethods
+test oo-17.13 {OO: class method unexport (bug 900cb0284bc)} -setup {
+ oo::class create c
+ oo::define c unexport m
+} -body {
+ lsort [info class methods c -all -private]
+} -cleanup {
+ c destroy
+} -result $stdmethods
+test oo-17.14 {OO: instance method unexport (bug 900cb0284bc)} -setup {
+ oo::class create c
+ oo::define c unexport m
+ c create o
+} -body {
+ lsort [info object methods o -all -private]
+} -cleanup {
+ o destroy
+ c destroy
+} -result $stdmethods
+
test oo-18.1 {OO: define command support} {
list [catch {oo::define oo::object {error foo}} msg] $msg $errorInfo
diff --git a/tests/scan.test b/tests/scan.test
index 7540c9c..b36b412 100644
--- a/tests/scan.test
+++ b/tests/scan.test
@@ -541,6 +541,24 @@ test scan-5.15 {Bug be003d570f} {
test scan-5.16 {Bug be003d570f} {
scan 0x40 %b
} 0
+test scan-5.17 {bigint scanning} -setup {
+ set a {}; set b {}; set c {}
+} -body {
+ list [scan "207698809136909011942886895,abcdef0123456789abcdef,125715736004432126361152746757" \
+ %lld,%llx,%llo a b c] $a $b $c
+} -result {3 207698809136909011942886895 207698809136909011942886895 207698809136909011942886895}
+test scan-5.18 {bigint scanning underflow} -setup {
+ set a {};
+} -body {
+ list [scan "-207698809136909011942886895" \
+ %llu a] $a
+} -returnCodes 1 -result {unsigned bignum scans are invalid}
+test scan-5.18 {bigint scanning invalid} -setup {
+ set a {};
+} -body {
+ list [scan "207698809136909011942886895" \
+ %llu a] $a
+} -returnCodes 1 -result {unsigned bignum scans are invalid}
test scan-6.1 {floating-point scanning} -setup {
set a {}; set b {}; set c {}; set d {}
diff --git a/tests/socket.test b/tests/socket.test
index 80b0251..d3d56fa 100644
--- a/tests/socket.test
+++ b/tests/socket.test
@@ -60,8 +60,13 @@
# listening at port 2048. If all fails, a message is printed and the tests
# using the remote server are not performed.
-package require tcltest 2
-namespace import -force ::tcltest::*
+if {[lsearch [namespace children] ::tcltest] == -1} {
+ package require tcltest
+ namespace import -force ::tcltest::*
+}
+
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
# Some tests require the Thread package or exec command
testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}]
@@ -69,7 +74,30 @@ testConstraint exec [llength [info commands exec]]
# Produce a random port number in the Dynamic/Private range
# from 49152 through 65535.
-proc randport {} { expr {int(rand()*16383+49152)} }
+proc randport {} {
+ # firstly try dynamic port via server-socket(0):
+ set port 0x7fffffff
+ catch {
+ set port [lindex [fconfigure [set s [socket -server {} 0]] -sockname] 2]
+ close $s
+ }
+ while {[catch {
+ close [socket -server {} $port]
+ } msg]} {
+ if {[incr i] > 1000} {return -code error "too many iterations to get free random port: $msg"}
+ # try random port:
+ set port [expr {int(rand()*16383+49152)}]
+ }
+ return $port
+}
+
+# Check if testsocket testflags is available
+testConstraint testsocket_testflags [expr {![catch {
+ set h [socket -async localhost [randport]]
+ testsocket testflags $h 0
+ close $h
+ }]}]
+
# Test the latency of tcp connections over the loopback interface. Some OSes
# (e.g. NetBSD) seem to use the Nagle algorithm and delayed ACKs, so it takes
@@ -2266,12 +2294,17 @@ test socket-14.11.0 {pending [socket -async] and nonblocking [puts], no listener
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} \
+ -constraints {socket testsocket_testflags} \
-body {
set sock [socket -async localhost [randport]]
+ # Set the socket in async test mode.
+ # The async connect will not be continued on the following fconfigure
+ # and puts/flush. Thus, the connect will fail after them.
+ testsocket testflags $sock 1
fconfigure $sock -blocking 0
puts $sock ok
flush $sock
+ testsocket testflags $sock 0
fileevent $sock writable {set x 1}
vwait x
close $sock
diff --git a/tests/util.test b/tests/util.test
index 1a3eecb..22d120b 100644
--- a/tests/util.test
+++ b/tests/util.test
@@ -4027,21 +4027,45 @@ test util-18.2 {Tcl_ObjPrintf} {testprint} {
} {9223372036854775807}
test util-18.3 {Tcl_ObjPrintf} {testprint} {
- testprint %Ld [expr 2**63-1]
+ testprint %qd [expr 2**63-1]
} {9223372036854775807}
test util-18.4 {Tcl_ObjPrintf} {testprint} {
+ testprint %jd [expr 2**63-1]
+} {9223372036854775807}
+
+test util-18.5 {Tcl_ObjPrintf} {testprint} {
testprint %lld [expr -2**63]
} {-9223372036854775808}
-test util-18.5 {Tcl_ObjPrintf} {testprint} {
+test util-18.6 {Tcl_ObjPrintf} {testprint} {
testprint %I64d [expr -2**63]
} {-9223372036854775808}
-test util-18.6 {Tcl_ObjPrintf} {testprint} {
- testprint %Ld [expr -2**63]
+test util-18.7 {Tcl_ObjPrintf} {testprint} {
+ testprint %qd [expr -2**63]
} {-9223372036854775808}
+test util-18.8 {Tcl_ObjPrintf} {testprint} {
+ testprint %jd [expr -2**63]
+} {-9223372036854775808}
+
+test util-18.9 {Tcl_ObjPrintf} {testprint} {
+ testprint "%I64d %I32d" [expr -2**63+2]
+} {-9223372036854775806 2}
+
+test util-18.10 {Tcl_ObjPrintf} {testprint} {
+ testprint "%I64d %p" 65535
+} {65535 0xffff}
+
+test util-18.11 {Tcl_ObjPrintf} {testprint} {
+ testprint "%I64d %td" 65536
+} {65536 65536}
+
+test util-18.12 {Tcl_ObjPrintf} {testprint} {
+ testprint "%I64d %Id" 65537
+} {65537 65537}
+
set ::tcl_precision $saved_precision
# cleanup
diff --git a/tests/zlib.test b/tests/zlib.test
index 63bac7e..c2f7825 100644
--- a/tests/zlib.test
+++ b/tests/zlib.test
@@ -330,7 +330,7 @@ test zlib-8.9 {transformation and fconfigure} -setup {
set strm [zlib stream decompress]
} -constraints zlib -body {
zlib push compress $outSide -dictionary $spdyDict
- fconfigure $outSide -blocking 0 -translation binary -buffering none
+ fconfigure $outSide -blocking 1 -translation binary -buffering none
fconfigure $inSide -blocking 1 -translation binary
puts -nonewline $outSide $spdyHeaders
set result [fconfigure $outSide -checksum]
@@ -347,7 +347,7 @@ test zlib-8.10 {transformation and fconfigure} -setup {
lassign [chan pipe] inSide outSide
} -constraints {zlib recentZlib} -body {
zlib push deflate $outSide -dictionary $spdyDict
- fconfigure $outSide -blocking 0 -translation binary -buffering none
+ fconfigure $outSide -blocking 1 -translation binary -buffering none
fconfigure $inSide -blocking 1 -translation binary
puts -nonewline $outSide $spdyHeaders
chan pop $outSide
@@ -369,7 +369,7 @@ test zlib-8.11 {transformation and fconfigure} -setup {
set strm [zlib stream inflate]
} -constraints zlib -body {
zlib push deflate $outSide -dictionary $spdyDict
- fconfigure $outSide -blocking 0 -translation binary -buffering none
+ fconfigure $outSide -blocking 1 -translation binary -buffering none
fconfigure $inSide -blocking 1 -translation binary
puts -nonewline $outSide $spdyHeaders
chan pop $outSide
@@ -387,7 +387,7 @@ test zlib-8.12 {transformation and fconfigure} -setup {
} -constraints zlib -body {
$strm put -dictionary $spdyDict -finalize $spdyHeaders
zlib push decompress $inSide
- fconfigure $outSide -blocking 0 -translation binary
+ fconfigure $outSide -blocking 1 -translation binary
fconfigure $inSide -translation binary -dictionary $spdyDict
puts -nonewline $outSide [$strm get]
close $outSide
@@ -404,7 +404,7 @@ test zlib-8.13 {transformation and fconfigure} -setup {
} -constraints zlib -body {
$strm put -dictionary $spdyDict -finalize $spdyHeaders
zlib push decompress $inSide -dictionary $spdyDict
- fconfigure $outSide -blocking 0 -translation binary
+ fconfigure $outSide -blocking 1 -translation binary
fconfigure $inSide -translation binary
puts -nonewline $outSide [$strm get]
close $outSide
@@ -421,7 +421,7 @@ test zlib-8.14 {transformation and fconfigure} -setup {
} -constraints zlib -body {
$strm put -finalize -dictionary $spdyDict $spdyHeaders
zlib push inflate $inSide
- fconfigure $outSide -blocking 0 -buffering none -translation binary
+ fconfigure $outSide -blocking 1 -buffering none -translation binary
fconfigure $inSide -translation binary -dictionary $spdyDict
puts -nonewline $outSide [$strm get]
close $outSide
@@ -437,7 +437,7 @@ test zlib-8.15 {transformation and fconfigure} -setup {
} -constraints zlib -body {
$strm put -finalize -dictionary $spdyDict $spdyHeaders
zlib push inflate $inSide -dictionary $spdyDict
- fconfigure $outSide -blocking 0 -buffering none -translation binary
+ fconfigure $outSide -blocking 1 -buffering none -translation binary
fconfigure $inSide -translation binary
puts -nonewline $outSide [$strm get]
close $outSide
@@ -1004,7 +1004,7 @@ test zlib-12.2 {Patrick Dunnigan's issue} -constraints zlib -setup {
} -cleanup {
removeFile $filesrc
removeFile $filedst
-} -result 4152
+} -result 56
::tcltest::cleanupTests
return
generated by cgit v0.12 at 2024-11-26 04:51:44 (GMT)