summaryrefslogtreecommitdiffstats
path: root/tests
diff options
context:
space:
mode:
Diffstat (limited to 'tests')
-rw-r--r--tests/chanio.test24
-rw-r--r--tests/clock.test19
-rw-r--r--tests/cmdAH.test24
-rw-r--r--tests/cmdMZ.test15
-rw-r--r--tests/encoding.test8
-rw-r--r--tests/info.test38
-rw-r--r--tests/interp.test72
-rw-r--r--tests/ioCmd.test5
-rw-r--r--tests/ioTrans.test2
-rw-r--r--tests/namespace.test16
-rw-r--r--tests/oo.test111
-rw-r--r--tests/remote.tcl8
-rw-r--r--tests/socket.test19
-rw-r--r--tests/zlib.test34
14 files changed, 310 insertions, 85 deletions
diff --git a/tests/chanio.test b/tests/chanio.test
index 0766c35..fb566d4 100644
--- a/tests/chanio.test
+++ b/tests/chanio.test
@@ -6649,7 +6649,7 @@ test chan-io-52.3 {TclCopyChannel} -constraints {fcopy} -setup {
} -body {
set f1 [open $thisScript]
set f2 [open $path(test1) w]
- chan configure $f1 -translation lf -encoding iso8859-1 -blocking 0
+ chan configure $f1 -translation binary -blocking 0
chan configure $f2 -translation cr -encoding iso8859-1 -blocking 0
set s0 [chan copy $f1 $f2]
set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]]
@@ -6680,8 +6680,8 @@ test chan-io-52.5 {TclCopyChannel, all} -constraints {fcopy} -setup {
} -body {
set f1 [open $thisScript]
set f2 [open $path(test1) w]
- chan configure $f1 -translation lf -encoding iso8859-1 -blocking 0
- chan configure $f2 -translation lf -encoding iso8859-1 -blocking 0
+ chan configure $f1 -translation binary -blocking 0
+ chan configure $f2 -translation binary -blocking 0
chan copy $f1 $f2 -size -1 ;# -1 means 'copy all', same as if no -size specified.
set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]]
chan close $f1
@@ -6696,8 +6696,8 @@ test chan-io-52.5a {TclCopyChannel, all, other negative value} -setup {
} -constraints {fcopy} -body {
set f1 [open $thisScript]
set f2 [open $path(test1) w]
- chan configure $f1 -translation lf -encoding iso8859-1 -blocking 0
- chan configure $f2 -translation lf -encoding iso8859-1 -blocking 0
+ chan configure $f1 -translation binary -blocking 0
+ chan configure $f2 -translation binary -blocking 0
chan copy $f1 $f2 -size -2 ;# < 0 behaves like -1, copy all
set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]]
chan close $f1
@@ -6712,8 +6712,8 @@ test chan-io-52.5b {TclCopyChannel, all, wrap to negative value} -setup {
} -constraints {fcopy} -body {
set f1 [open $thisScript]
set f2 [open $path(test1) w]
- chan configure $f1 -translation lf -encoding iso8859-1 -blocking 0
- chan configure $f2 -translation lf -encoding iso8859-1 -blocking 0
+ chan configure $f1 -translation binary -blocking 0
+ chan configure $f2 -translation binary -blocking 0
chan copy $f1 $f2 -size 3221176172 ;# Wrapped to < 0, behaves like -1, copy all
set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]]
chan close $f1
@@ -6728,8 +6728,8 @@ test chan-io-52.6 {TclCopyChannel} -setup {
} -constraints {fcopy} -body {
set f1 [open $thisScript]
set f2 [open $path(test1) w]
- chan configure $f1 -translation lf -encoding iso8859-1 -blocking 0
- chan configure $f2 -translation lf -encoding iso8859-1 -blocking 0
+ chan configure $f1 -translation binary -blocking 0
+ chan configure $f2 -translation binary -blocking 0
set s0 [chan copy $f1 $f2 -size [expr {[file size $thisScript] + 5}]]
set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]]
chan close $f1
@@ -6746,8 +6746,8 @@ test chan-io-52.7 {TclCopyChannel} -constraints {fcopy} -setup {
} -body {
set f1 [open $thisScript]
set f2 [open $path(test1) w]
- chan configure $f1 -translation lf -encoding iso8859-1 -blocking 0
- chan configure $f2 -translation lf -encoding iso8859-1 -blocking 0
+ chan configure $f1 -translation binary -blocking 0
+ chan configure $f2 -translation binary -blocking 0
chan copy $f1 $f2
set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]]
if {[file size $thisScript] == [file size $path(test1)]} {
@@ -6864,7 +6864,7 @@ test chan-io-53.2 {CopyData} -setup {
} -constraints {fcopy} -body {
set f1 [open $thisScript]
set f2 [open $path(test1) w]
- chan configure $f1 -translation lf -encoding iso8859-1 -blocking 0
+ chan configure $f1 -translation binary -blocking 0
chan configure $f2 -translation cr -encoding iso8859-1 -blocking 0
chan copy $f1 $f2 -command [namespace code {set s0}]
set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]]
diff --git a/tests/clock.test b/tests/clock.test
index b54d9f0..70d527e 100644
--- a/tests/clock.test
+++ b/tests/clock.test
@@ -36113,6 +36113,25 @@ test clock-46.4 {regression test - month thirteen} \
clock scan 20041301
} -result [clock scan 2005-01-01 -format %Y-%m-%d]
+test clock-46.5 {regression test - good time} \
+ -body {
+ # 12:01 apm are valid input strings...
+ list [clock scan "12:01 am" -base 0 -gmt 1] \
+ [clock scan "12:01 pm" -base 0 -gmt 1]
+ } -result {60 43260}
+test clock-46.6 {freescan: regression test - bad time} \
+ -body {
+ # 13:00 am/pm are invalid input strings...
+ list [clock scan "13:00 am" -base 0 -gmt 1] \
+ [clock scan "13:00 pm" -base 0 -gmt 1]
+ } -result {-1 -1}
+
+test clock-46.7 {regression test - switch day by large not-valid time, see bug [3ee8f1c2a785f4d8]} {
+ list [clock scan 23:59:59 -base 0 -gmt 1 -format %H:%M:%S] \
+ [clock scan 24:00:00 -base 0 -gmt 1 -format %H:%M:%S] \
+ [clock scan 48:00:00 -base 0 -gmt 1 -format %H:%M:%S]
+} {86399 86400 172800}
+
test clock-47.1 {regression test - four-digit time} {
clock scan 0012
} [clock scan 0012 -format %H%M]
diff --git a/tests/cmdAH.test b/tests/cmdAH.test
index 526c261..614ec0f 100644
--- a/tests/cmdAH.test
+++ b/tests/cmdAH.test
@@ -22,8 +22,24 @@ testConstraint testchmod [llength [info commands testchmod]]
testConstraint testsetplatform [llength [info commands testsetplatform]]
testConstraint testvolumetype [llength [info commands testvolumetype]]
testConstraint time64bit [expr {
- $::tcl_platform(pointerSize) >= 8 ||
- [llength [info command testsize]] && [testsize st_mtime] >= 8
+ ([llength [info command testsize]] ?
+ [testsize st_mtime] : $::tcl_platform(pointerSize)) >= 8
+}]
+testConstraint filetime64bit [expr {
+ [testConstraint time64bit] && (
+ ![testConstraint unix] || [apply {{} {
+ # check whether disk may have 2038 problem, see [fd91b0ca09cb171f]:
+ set fn [makeFile "" foo.text]
+ if {[catch {
+ exec sh -c "TZ=:UTC LC_TIME=en_US touch -ma -t '207006290000' '$fn' && TZ=:UTC LC_TIME=en_US ls -l '$fn'"
+ } res]} {
+ #puts "Check constraint failed:\t$res"
+ set res {}
+ }
+ removeFile $fn
+ regexp {\mJun\s+29\s+2070\M} $res
+ }}]
+ )
}]
testConstraint linkDirectory [expr {
![testConstraint win] ||
@@ -1296,14 +1312,14 @@ test cmdAH-24.14.1 {
} -match regexp -result {could not (?:get modification time|read)} -returnCodes error
# 3155760000 is 64-bit Unix time, Wed Jan 01 00:00:00 GMT 2070:
-test cmdAH-24.20.1 {Tcl_FileObjCmd: atime 64-bit time_t, bug [4718b41c56]} -constraints {time64bit} -setup {
+test cmdAH-24.20.1 {Tcl_FileObjCmd: atime 64-bit time_t, bug [4718b41c56]} -constraints {time64bit filetime64bit} -setup {
set filename [makeFile "" foo.text]
} -body {
list [file atime $filename 3155760000] [file atime $filename]
} -cleanup {
removeFile $filename
} -result {3155760000 3155760000}
-test cmdAH-24.20.2 {Tcl_FileObjCmd: mtime 64-bit time_t, bug [4718b41c56]} -constraints {time64bit} -setup {
+test cmdAH-24.20.2 {Tcl_FileObjCmd: mtime 64-bit time_t, bug [4718b41c56]} -constraints {time64bit filetime64bit} -setup {
set filename [makeFile "" foo.text]
} -body {
list [file mtime $filename 3155760000] [file mtime $filename]
diff --git a/tests/cmdMZ.test b/tests/cmdMZ.test
index ff6efaa..cf63b9f 100644
--- a/tests/cmdMZ.test
+++ b/tests/cmdMZ.test
@@ -324,11 +324,15 @@ test cmdMZ-4.13 {Tcl_SplitObjCmd: basic split commands} {
# todo: rewrite this if monotonic clock is provided resp. command "after"
# gets microsecond accuracy (RFE [fdfbd5e10] gets merged):
proc _nrt_sleep {msec} {
- set usec [expr {$msec * 1000}]
set stime [clock microseconds]
- while {abs([clock microseconds] - $stime) < $usec} {
- # don't use after 0 unless it's NRT-capable, so yes - busy-wait (but it's more precise):
- # after 0
+ set usec [expr {$msec * 1000}]
+ set etime [expr {$stime + $usec}]
+ while {[set tm [clock microseconds]] < $etime} {
+ # don't use after 0 unless it's NRT-capable, so yes - busy-wait (but it's more precise):
+ # after 0
+ if {$tm < $stime} { # avoid too long delays by backwards time jumps, simply skip test
+ tcltest::Skip "time-jump?"
+ }
}
}
_nrt_sleep 0; # warm up (clock, compile, etc)
@@ -408,6 +412,9 @@ test cmdMZ-6.5b {Tcl_TimeRateObjCmd: result format without iterations} {
test cmdMZ-6.6 {Tcl_TimeRateObjCmd: slower commands take longer, but it remains almost the same time of measurement} -body {
set m1 [timerate {_nrt_sleep 0.01} 50]
set m2 [timerate {_nrt_sleep 1.00} 50]
+ if {[testConstraint valgrind] && ([lindex $m1 0] >= 100 || [lindex $m1 2] <= 500)} {
+ tcltest::Skip "too-slow-by-valgrind"
+ }
list [list \
[expr {[lindex $m1 0] < [lindex $m2 0]}] \
[expr {[lindex $m1 0] < 100}] \
diff --git a/tests/encoding.test b/tests/encoding.test
index 3feaa55..93a52aa 100644
--- a/tests/encoding.test
+++ b/tests/encoding.test
@@ -183,11 +183,11 @@ test encoding-7.2 {Tcl_UtfToExternalDString: big buffer} {
test encoding-8.1 {Tcl_ExternalToUtf} {
set f [open [file join [temporaryDirectory] dummy] w]
- fconfigure $f -translation binary -encoding iso8859-1
+ fconfigure $f -translation binary
puts -nonewline $f "ab\x8C\xC1g"
close $f
set f [open [file join [temporaryDirectory] dummy] r]
- fconfigure $f -translation binary -encoding shiftjis
+ fconfigure $f -translation lf -encoding shiftjis
set x [read $f]
close $f
file delete [file join [temporaryDirectory] dummy]
@@ -211,11 +211,11 @@ test encoding-9.2 {Tcl_UtfToExternalDString: big buffer} {
test encoding-10.1 {Tcl_UtfToExternal} {
set f [open [file join [temporaryDirectory] dummy] w]
- fconfigure $f -translation binary -encoding shiftjis
+ fconfigure $f -translation lf -encoding shiftjis
puts -nonewline $f "ab\u4E4Eg"
close $f
set f [open [file join [temporaryDirectory] dummy] r]
- fconfigure $f -translation binary -encoding iso8859-1
+ fconfigure $f -translation binary
set x [read $f]
close $f
file delete [file join [temporaryDirectory] dummy]
diff --git a/tests/info.test b/tests/info.test
index 69be6a3..140a7bb 100644
--- a/tests/info.test
+++ b/tests/info.test
@@ -1841,7 +1841,7 @@ test info-30.48 {Bug 2850901} testevalex {
# -------------------------------------------------------------------------
# literal sharing 2, bug 2933089
-test info-40.1 {location information not confused by literal sharing, bug 2933089} -setup {
+test info-39.1 {location information not confused by literal sharing, bug 2933089} -setup {
set result {}
proc print_one {} {}
@@ -2398,6 +2398,28 @@ test info-33.35 {{*}, literal, simple, bytecompiled} -body {
# -------------------------------------------------------------------------
unset -nocomplain res
+test info-19.7 {info vars: before TIP #278 - global vars resolved in namespace} -setup {
+ catch {namespace delete x}
+} -body {
+ expr { [llength [namespace eval x {info vars}]] > 0 }
+} -cleanup {
+ namespace delete x
+} -result 1
+test info-19.8 {info vars: before TIP #278 - global vars resolved in namespace} -setup {
+ catch {namespace delete x}
+} -body {
+ namespace eval x {info vars tcl_platform}
+} -cleanup {
+ namespace delete x
+} -result {tcl_platform}
+test info-19.9 {info vars: global vars resolved by pattern} -setup {
+ catch {namespace delete x}
+} -body {
+ namespace eval x {info vars ::tcl_platform}
+} -cleanup {
+ namespace delete x
+} -result {::tcl_platform}
+
test info-39.2 {Bug 4b61afd660} -setup {
proc probe {} {
return [dict get [info frame -1] line]
@@ -2415,6 +2437,20 @@ test info-39.2 {Bug 4b61afd660} -setup {
rename probe {}
} -result 3
+test info-41.0 {Bug 0de6c1d79c crash} -setup {
+ interp create child
+ child hide info
+} -body {
+ list [child invokehidden info frame] \
+ [child invokehidden info frame 0] \
+ [child invokehidden info frame 1] \
+ [catch {child invokehidden info frame -1} msg] $msg \
+ [catch {child invokehidden info frame 2} msg] $msg
+} -cleanup {
+ interp delete child
+ unset -nocomplain msg
+} -result {1 {type precompiled} {type precompiled} 1 {bad level "-1"} 1 {bad level "2"}}
+
# cleanup
catch {namespace delete test_ns_info1 test_ns_info2}
::tcltest::cleanupTests
diff --git a/tests/interp.test b/tests/interp.test
index d742484..24ffb1b 100644
--- a/tests/interp.test
+++ b/tests/interp.test
@@ -22,6 +22,12 @@ testConstraint testinterpdelete [llength [info commands testinterpdelete]]
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}
+proc _ms_limit_args {ms {t0 {}}} {
+ if {$t0 eq {}} { set t0 [clock milliseconds] }
+ incr t0 $ms
+ list -seconds [expr {$t0 / 1000}] -milliseconds [expr {$t0 % 1000}]
+}
+
foreach i [interp children] {
interp delete $i
}
@@ -3155,7 +3161,7 @@ test interp-34.3 {basic test of limits - pure bytecode loop} -body {
}
}
# We use a time limit here; command limits don't trap this case
- $i limit time -seconds [expr {[clock seconds]+2}]
+ $i limit time {*}[_ms_limit_args 50]
$i eval foobar
} -returnCodes error -result {time limit exceeded} -cleanup {
interp delete $i
@@ -3171,7 +3177,7 @@ test interp-34.3.1 {basic test of limits - pure inside-command loop} -body {
}
}
# We use a time limit here; command limits don't trap this case
- $i limit time -seconds [expr {[clock seconds] + 2}]
+ $i limit time {*}[_ms_limit_args 50]
$i eval foobar
} -returnCodes error -result {time limit exceeded} -cleanup {
interp delete $i
@@ -3304,7 +3310,7 @@ test interp-34.7 {limits with callbacks: deleting the handler interp} -setup {
# Bug 1085023
test interp-34.8 {time limits trigger in vwaits} -body {
set i [interp create]
- interp limit $i time -seconds [expr {[clock seconds] + 1}] -granularity 1
+ interp limit $i time {*}[_ms_limit_args 50] -granularity 1
$i eval {
set x {}
vwait x
@@ -3314,21 +3320,20 @@ test interp-34.8 {time limits trigger in vwaits} -body {
} -returnCodes error -result {limit exceeded}
test interp-34.9 {time limits trigger in blocking after} {
set i [interp create]
- set t0 [clock seconds]
- interp limit $i time -seconds [expr {$t0 + 1}] -granularity 1
+ set t0 [clock milliseconds]
+ interp limit $i time {*}[_ms_limit_args 50 $t0] -granularity 1
set code [catch {
$i eval {after 10000}
} msg]
- set t1 [clock seconds]
+ set t1 [clock milliseconds]
interp delete $i
- list $code $msg [expr {($t1-$t0) < 3 ? "OK" : $t1-$t0}]
+ list $code $msg [expr {($t1-$t0) < 1000 ? "OK" : $t1-$t0}]
} {1 {time limit exceeded} OK}
test interp-34.10 {time limits trigger in vwaits: Bug 1221395} -body {
set i [interp create]
- # Assume someone hasn't set the clock to early 1970!
- $i limit time -seconds 1 -granularity 4
interp alias $i log {} lappend result
set result {}
+ $i limit time {*}[_ms_limit_args 50] -granularity 4
catch {
$i eval {
log 1
@@ -3340,10 +3345,10 @@ test interp-34.10 {time limits trigger in vwaits: Bug 1221395} -body {
lappend result $msg
} -result {1 {time limit exceeded}}
test interp-34.11 {time limit extension in callbacks} -setup {
- proc cb1 {i t} {
+ proc cb1 {i args} {
global result
lappend result cb1
- $i limit time -seconds $t -command cb2
+ $i limit time {*}[_ms_limit_args {*}$args] -command cb2
}
proc cb2 {} {
global result
@@ -3351,9 +3356,9 @@ test interp-34.11 {time limit extension in callbacks} -setup {
}
} -body {
set i [interp create]
- set t0 [clock seconds]
- $i limit time -seconds [expr {$t0 + 1}] -granularity 1 \
- -command "cb1 $i [expr {$t0 + 2}]"
+ set t0 [clock milliseconds]
+ $i limit time {*}[_ms_limit_args 50 $t0] \
+ -command "cb1 $i 100 $t0"
set ::result {}
lappend ::result [catch {
$i eval {
@@ -3362,8 +3367,8 @@ test interp-34.11 {time limit extension in callbacks} -setup {
}
}
} msg] $msg
- set t1 [clock seconds]
- lappend ::result [expr {$t1-$t0>=2 ? "ok" : "$t0,$t1"}]
+ set t1 [clock milliseconds]
+ lappend ::result [expr {$t1-$t0>=100 ? "ok" : "$t0,$t1"}]
interp delete $i
return $::result
} -result {cb1 cb2 1 {time limit exceeded} ok} -cleanup {
@@ -3371,27 +3376,27 @@ test interp-34.11 {time limit extension in callbacks} -setup {
rename cb2 {}
}
test interp-34.12 {time limit extension in callbacks} -setup {
- proc cb1 {i} {
+ proc cb1 {i t0} {
global result times
lappend result cb1
set times [lassign $times t]
- $i limit time -seconds $t
+ $i limit time {*}[_ms_limit_args $t $t0]
}
} -body {
set i [interp create]
- set t0 [clock seconds]
- set ::times "[expr {$t0 + 2}] [expr {$t0 + 100}]"
- $i limit time -seconds [expr {$t0 + 1}] -granularity 1 -command "cb1 $i"
+ set t0 [clock milliseconds]
+ set ::times {100 10000}
+ $i limit time {*}[_ms_limit_args 50] -granularity 1 -command "cb1 $i $t0"
set ::result {}
lappend ::result [catch {
$i eval {
- for {set i 0} {$i<30} {incr i} {
- after 100
+ for {set i 0} {$i<5} {incr i} {
+ after 50
}
}
} msg] $msg
- set t1 [clock seconds]
- lappend ::result [expr {$t1-$t0>=2 ? "ok" : "$t0,$t1"}]
+ set t1 [clock milliseconds]
+ lappend ::result [expr {$t1-$t0>=100 ? "ok" : "$t0,$t1"}]
interp delete $i
return $::result
} -result {cb1 cb1 0 {} ok} -cleanup {
@@ -3400,7 +3405,7 @@ test interp-34.12 {time limit extension in callbacks} -setup {
test interp-34.13 {time limit granularity and vwait: Bug 2891362} -setup {
set i [interp create -safe]
} -body {
- $i limit time -seconds [clock add [clock seconds] 1 second]
+ $i limit time {*}[_ms_limit_args 50]
$i eval {
after 2000 set x timeout
vwait x
@@ -3409,6 +3414,20 @@ test interp-34.13 {time limit granularity and vwait: Bug 2891362} -setup {
} -cleanup {
interp delete $i
} -returnCodes error -result {limit exceeded}
+test interp-34.14 {[Bug e3f4a8b78d]: interp limit and interp eval} -setup {
+ set i [interp create]
+ set result {}
+} -body {
+ $i limit command -value [$i eval {info cmdcount}] -granularity 1
+ lappend result [catch {$i eval [list expr 1+3]} msg] $msg
+ lappend result [catch {$i eval [list expr 1+3]} msg] $msg
+ lappend result [catch {$i eval {set cmd expr; $cmd 1+3}} msg] $msg
+ lappend result [catch {$i eval {expr 1+3}} msg] $msg
+ lappend result [catch {$i eval expr 1+3} msg] $msg
+ lappend result [catch {interp eval $i [list expr 1+3]} msg] $msg
+} -cleanup {
+ interp delete $i
+} -result [lrepeat 6 1 {command count limit exceeded}]
test interp-35.1 {interp limit syntax} -body {
interp limit
@@ -3670,6 +3689,7 @@ unset -nocomplain hidden_cmds
foreach i [interp children] {
interp delete $i
}
+rename _ms_limit_args {}
::tcltest::cleanupTests
return
diff --git a/tests/ioCmd.test b/tests/ioCmd.test
index 74fabe7..b167475 100644
--- a/tests/ioCmd.test
+++ b/tests/ioCmd.test
@@ -61,7 +61,7 @@ test iocmd-1.7 {puts command} {
} 7
test iocmd-1.8 {puts command} {
set f [open $path(test1) w]
- fconfigure $f -translation lf -eofchar {} -encoding iso8859-1
+ fconfigure $f -translation binary
puts -nonewline $f [binary format a4a5 foo bar]
close $f
file size $path(test1)
@@ -249,8 +249,7 @@ test iocmd-8.8 {fconfigure command} {
test iocmd-8.9 {fconfigure command} {
file delete $path(test1)
set f1 [open $path(test1) w]
- fconfigure $f1 -translation binary -buffering none -buffersize 4040 \
- -eofchar {} -encoding binary
+ fconfigure $f1 -translation binary -buffering none -buffersize 4040
set x [fconfigure $f1]
close $f1
set x
diff --git a/tests/ioTrans.test b/tests/ioTrans.test
index 4eafb6b..47006aa 100644
--- a/tests/ioTrans.test
+++ b/tests/ioTrans.test
@@ -2096,8 +2096,6 @@ test iortrans.tf-11.0 {origin thread of moved transform gone} -setup {
thread::release $tidb
} -result {1 {Owner lost} 0 0 1 {Owner lost} 1 {Owner lost} 1 {Owner lost}}
-testConstraint notValgrind [expr {![testConstraint valgrind]}]
-
test iortrans.tf-11.1 {origin thread of moved transform destroyed during access} -setup {
#puts <<$tcltest::mainThread>>main
set tida [thread::create -preserved]; #puts <<$tida>>
diff --git a/tests/namespace.test b/tests/namespace.test
index 08531e4..17c9438 100644
--- a/tests/namespace.test
+++ b/tests/namespace.test
@@ -3294,6 +3294,22 @@ test namespace-55.1 {compiled ensembles inside compiled ensembles: Bug 6d2f249a0
info class [format %s constructor] oo::object
} ""
+test namespace-55.2 {compiled ensembles inside safe interpreters (for safe sub-commands), bug [1095bf7f756f9aed]} -setup {
+ interp create -safe si
+ set code {
+ proc test_comp_dict d { dict for {k v} $d {expr $v} }
+ regexp -inline {Command 1:(?:[^\n]*\n){1,5}} [::tcl::unsupported::disassemble proc test_comp_dict]
+ }
+} -body {
+ set a [ eval $code]
+ set b [si eval $code]
+ list [expr {$a eq $b}] [regexp { dictFirst } $a] [regexp { dictFirst } $b] $a $b
+} -cleanup {
+ rename test_comp_dict {}
+ unset -nocomplain code a b
+ interp delete si
+} -match glob -result {1 1 1 *}
+
test namespace-56.1 {bug f97d4ee020: mutually-entangled deletion} {
namespace eval ::testing {
proc abc {} {}
diff --git a/tests/oo.test b/tests/oo.test
index c940011..6bf9c70 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -13,6 +13,20 @@ if {"::tcltest" ni [namespace children]} {
namespace import -force ::tcltest::*
}
+# A helper for intercepting background errors
+proc ::bgerrorIntercept {varName body} {
+ set old [interp bgerror {}]
+ interp bgerror {} [list apply {{var msg args} {
+ upvar #0 $var v
+ lappend v $msg
+ }} $varName]
+ try {
+ uplevel 1 $body
+ } finally {
+ interp bgerror {} $old
+ }
+}
+
# The foundational objects oo::object and oo::class are sensitive to reference
# counting errors and are deallocated only when an interp is deleted, so in
@@ -668,28 +682,30 @@ test oo-3.6 {basic test of OO functionality: errors in destructor} -setup {
} -result {1 foo {}}
test oo-3.7 {basic test of OO functionality: errors in destructor} -setup {
oo::class create cls
- set result {}
- proc bgerror msg {lappend ::result $msg}
} -cleanup {
cls destroy
- rename bgerror {}
} -body {
oo::define cls destructor {error foo}
- list [rename [cls create obj] {}] \
- [update idletasks] $result [info commands obj]
-} -result {{} {} foo {}}
+ bgerrorIntercept result {
+ set result [cls create obj]
+ lappend result [rename obj {}]
+ update idletasks
+ lappend result [info commands obj]
+ }
+} -result {::obj {} foo {}}
test oo-3.8 {basic test of OO functionality: errors in destructor} -setup {
oo::class create cls
- set result {}
- proc bgerror msg {lappend ::result $msg}
} -cleanup {
cls destroy
- rename bgerror {}
} -body {
oo::define cls destructor {error foo}
- list [namespace delete [info object namespace [cls create obj]]] \
- [update idletasks] $result [info commands obj]
-} -result {{} {} foo {}}
+ bgerrorIntercept result {
+ set result [cls create obj]
+ lappend result [namespace delete [info object namespace obj]]
+ update idletasks
+ lappend result [info commands obj]
+ }
+} -result {::obj {} foo {}}
test oo-3.9 {Bug 2944404: deleting the object in the destructor} -setup {
oo::class create cls
set result {}
@@ -2854,6 +2870,16 @@ test oo-18.11 {OO: define/self command support} -setup {
(in definition script for class "::foo" line 1)
invoked from within
"oo::define foo {rename ::foo {}; self {error foobar}}"}
+test oo-18.12 {OO: self callable via eval method} -setup {
+ oo::class create parent {
+ export eval
+ }
+ parent create ::foo
+} -body {
+ foo eval { self }
+} -cleanup {
+ parent destroy
+} -result ::foo
test oo-19.1 {OO: varname method} -setup {
oo::object create inst
@@ -2907,6 +2933,20 @@ test oo-19.3 {OO: varname method and variable decl: Bug 3603695} -setup {
} -cleanup {
testClass destroy
} -result 0
+test oo-19.4 {OO: varname ghosts [Bug 74b6110204]} -setup {
+ oo::class create testClass {
+ export varname
+ self export createWithNamespace
+ }
+ set obj [testClass createWithNamespace testoo19_4 testoo19_4]
+ set ns [info object namespace $obj]
+} -body {
+ set v [$obj varname foo]
+ list [namespace which -variable $v] \
+ [info exists $v] [namespace which -variable $v]
+} -cleanup {
+ testClass destroy
+} -result {::testoo19_4::foo 0 ::testoo19_4::foo}
test oo-20.1 {OO: variable method} -body {
oo::class create testClass {
@@ -3324,7 +3364,7 @@ oo::class create WorkerSupport {
return [uplevel 1 $script]
} finally {
foreach worker $workers {$worker destroy}
- }
+ }
}
method run {nworkers} {
set result {}
@@ -4332,13 +4372,20 @@ test oo-35.7.1 {Bug 7842f33a5c: destructor cascading in stereotypes} -setup {
}
set ::result {}
} -body {
- set FH [RpcClient new]
- $FH create_bug
- $FH destroy
+ # In this case, sub-objects are deleted during major object NS cleanup and
+ # are trying to call back into the major object (which is mostky gone at
+ # this point). Things are messy; error is reported via bgerror as the
+ # avenue most likely to reach a user.
+ bgerrorIntercept ::result {
+ set FH [RpcClient new]
+ $FH create_bug
+ $FH destroy
+ update
+ }
join $result \n
} -cleanup {
base destroy
-} -result {}
+} -result {impossible to invoke method "write": no defined method or unknown method}
test oo-35.7.2 {Bug 7842f33a5c: destructor cascading in stereotypes} -setup {
oo::class create base
oo::class create RpcClient {
@@ -4366,13 +4413,21 @@ test oo-35.7.2 {Bug 7842f33a5c: destructor cascading in stereotypes} -setup {
}
set ::result {}
} -body {
- set FH [RpcClient new]
- $FH create_bug
- $FH destroy
+ # In this case, sub-objects are deleted during major object NS cleanup, and
+ # we've a destructor on the major class to monitor when it happens. Things
+ # are still messy, but the order is clear; error is reported via bgerror as
+ # the avenue most likely to reach a user.
+ bgerrorIntercept ::result {
+ set FH [RpcClient new]
+ $FH create_bug
+ $FH destroy
+ update
+ }
join $result \n
} -cleanup {
base destroy
-} -result {Destroyed}
+} -result {Destroyed
+impossible to invoke method "write": no defined method or unknown method}
test oo-35.7.3 {Bug 7842f33a5c: destructor cascading in stereotypes} -setup {
oo::class create base
oo::class create RpcClient {
@@ -4407,14 +4462,20 @@ test oo-35.7.3 {Bug 7842f33a5c: destructor cascading in stereotypes} -setup {
}
set ::result {}
} -body {
- set FH [RpcClient new]
- $FH create_bug
- $FH destroy
+ # In this case, sub-objects are deleted while the destructor is running and
+ # the destroy is neat, so things work sanely. Error follows standard Tcl
+ # error flow route; bgerror is not used.
+ bgerrorIntercept ::result {
+ set FH [RpcClient new]
+ $FH create_bug
+ $FH destroy
+ update
+ }
join $result \n
} -cleanup {
base destroy
} -result "Destroyed\nRpcClient -> otto-111"
-
+rename bgerrorIntercept {}
cleanupTests
return
diff --git a/tests/remote.tcl b/tests/remote.tcl
index 2b975c6..6a39b47 100644
--- a/tests/remote.tcl
+++ b/tests/remote.tcl
@@ -40,9 +40,9 @@ proc __readAndExecute__ {s} {
set l [gets $s]
if {[string compare $l "--Marker--Marker--Marker--"] == 0} {
- puts $s [__doCommands__ $command($s) $s]
+ puts $s [__doCommands__ $command($s) $s]
puts $s "--Marker--Marker--Marker--"
- set command($s) ""
+ set command($s) ""
return
}
if {[string compare $l ""] == 0} {
@@ -59,8 +59,8 @@ proc __readAndExecute__ {s} {
puts "Server closing $s, eof from client"
}
close $s
- unset command($s)
- return
+ unset command($s)
+ return
}
append command($s) $l "\n"
}
diff --git a/tests/socket.test b/tests/socket.test
index 7251bfa..31d41ba 100644
--- a/tests/socket.test
+++ b/tests/socket.test
@@ -1079,6 +1079,25 @@ test socket_$af-7.5 {testing socket specific options} -setup {
close $s
close $s1
} -result [list $localhost 1 3]
+test socket_$af-7.6 {testing socket specific options - bug e589d9bdab} -setup {
+ set timer [after 10000 "set x timed_out"]
+ set l ""
+} -constraints [list socket supported_$af unixOrWin] -body {
+ set s [socket -server accept 0]
+ proc accept {s a p} {
+ global x
+ set x [fconfigure $s -sockname]
+ close $s
+ }
+ set listen [lindex [fconfigure $s -sockname] 2]
+ set s1 [socket $localhost $listen]
+ vwait x
+ lsort [dict keys [fconfigure $s1]]
+} -cleanup {
+ after cancel $timer
+ close $s
+ close $s1
+} -result {-blocking -buffering -buffersize -encoding -eofchar -peername -sockname -translation}
test socket_$af-8.1 {testing -async flag on sockets} -constraints [list socket supported_$af] -body {
# NOTE: This test may fail on some Solaris 2.4 systems. If it does, check
diff --git a/tests/zlib.test b/tests/zlib.test
index 5312d2b..61bddd9 100644
--- a/tests/zlib.test
+++ b/tests/zlib.test
@@ -1117,6 +1117,40 @@ if {$zlibbinf ne ""} {
unset zlibbinf
rename _zlibbinf {}
+test zlib-14.1 {Bug 9ee9f4d7be: compression header added to source channel} -setup {
+ set data hello
+ set src [file tempfile]
+ puts -nonewline $src $data
+ flush $src
+ chan configure $src -translation binary
+ set dst [file tempfile]
+ chan configure $dst -translation binary
+ set result {}
+} -constraints knownBug -body {
+ for {set i 0} {$i < 3} {incr i} {
+ # Determine size of src channel
+ seek $src 0 end
+ set size [chan tell $src]
+ seek $src 0 start
+ # Determine size of content in src channel
+ set data [read $src]
+ set size2 [string length $data]
+ seek $src 0 start
+ # Copy src over to dst, keep dst empty
+ zlib push deflate $src -level 6
+ chan truncate $dst 0
+ chan copy $src $dst
+ set size3 [chan tell $dst]
+ chan pop $src
+ # Show sizes
+ lappend result $size $size2 ->$size3
+ }
+ return $result
+} -cleanup {
+ chan close $src
+ chan close $dst
+} -result {5 5 ->5 5 5 ->5 5 5 ->5}
+
::tcltest::cleanupTests
return
generated by cgit v0.12 at 2025-12-16 00:25:29 (GMT)