summaryrefslogtreecommitdiffstats
path: root/tests
diff options
context:
space:
mode:
Diffstat (limited to 'tests')
-rw-r--r--tests/assemble.test3
-rw-r--r--tests/binary.test28
-rw-r--r--tests/coroutine.test33
-rw-r--r--tests/error.test10
-rw-r--r--tests/interp.test14
-rw-r--r--tests/misc.test7
-rw-r--r--tests/oo.test99
-rw-r--r--tests/parse.test27
-rw-r--r--tests/reg.test3
-rw-r--r--tests/regexp.test4
-rw-r--r--tests/rename.test7
-rw-r--r--tests/safe.test80
-rw-r--r--tests/subst.test4
-rw-r--r--tests/trace.test7
-rw-r--r--tests/unixForkEvent.test45
-rw-r--r--tests/zlib.test21
16 files changed, 375 insertions, 17 deletions
diff --git a/tests/assemble.test b/tests/assemble.test
index 7d4e5d1..b0487e6 100644
--- a/tests/assemble.test
+++ b/tests/assemble.test
@@ -175,8 +175,7 @@ test assemble-4.1 {syntax error} {
-match glob
-result {1 {extra characters after close-brace} {extra characters after close-brace
while executing
-"{}extra
- "
+"{}e"
("assemble" body, line 2)*}}
}
test assemble-4.2 {null command} {
diff --git a/tests/binary.test b/tests/binary.test
index 4393245..d424837 100644
--- a/tests/binary.test
+++ b/tests/binary.test
@@ -2499,6 +2499,34 @@ test binary-71.9 {binary decode hex} -body {
test binary-71.10 {binary decode hex} -body {
string length [binary decode hex " "]
} -result 0
+test binary-71.11 {binary decode hex: Bug b98fa55285} -body {
+ apply {{} {
+ set str "137b6f95e7519389e7c4b36599781e2ccf492699649249aae43fbe8c26\n"
+ set decoded [binary decode hex $str]
+ list [string length $decoded] [scan [string index $decoded end] %c]
+ }}
+} -result {29 38}
+test binary-71.12 {binary decode hex: Bug b98fa55285 cross check} -body {
+ apply {{} {
+ set str "137b6f95e7519389e7c4b36599781e2ccf492699649249aae43fbe8c2\n"
+ set decoded [binary decode hex $str]
+ list [string length $decoded] [scan [string index $decoded end] %c]
+ }}
+} -result {28 140}
+test binary-71.13 {binary decode hex: Bug b98fa55285 cross check} -body {
+ apply {{} {
+ set str "137b6f95e7519389e7c4b36599781e2ccf492699649249aae43fbe8c2\n\n"
+ set decoded [binary decode hex $str]
+ list [string length $decoded] [scan [string index $decoded end] %c]
+ }}
+} -result {28 140}
+test binary-71.14 {binary decode hex: Bug b98fa55285 cross check} -body {
+ apply {{} {
+ set str "137b6f95e7519389e7c4b36599781e2ccf492699649249aae43fbe8c2\n\n\n"
+ set decoded [binary decode hex $str]
+ list [string length $decoded] [scan [string index $decoded end] %c]
+ }}
+} -result {28 140}
test binary-72.1 {binary encode base64} -body {
binary encode base64
diff --git a/tests/coroutine.test b/tests/coroutine.test
index 1d9040b..03c63ad 100644
--- a/tests/coroutine.test
+++ b/tests/coroutine.test
@@ -609,6 +609,39 @@ test coroutine-7.3 {yielding between coroutines} -body {
} -cleanup {
catch {rename juggler ""}
} -result {{{a b c d e} ::j1 {a b c d} ::j2 {a b c} ::j3 {a b} ::j1 a ::j2} {} {} {}}
+
+test coroutine-7.4 {Bug 8ff0cb9fe1} -setup {
+ proc foo {a b} {catch yield; return 1}
+} -cleanup {
+ rename foo {}
+} -body {
+ coroutine demo lsort -command foo {a b}
+} -result {b a}
+
+test coroutine-7.5 {return codes} {
+ set result {}
+ foreach code {0 1 2 3 4 5} {
+ lappend result [catch {coroutine demo return -level 0 -code $code}]
+ }
+ set result
+} {0 1 2 3 4 5}
+
+test coroutine-7.6 {Early yield crashes} {
+ proc foo args {}
+ trace add execution foo enter {catch yield}
+ coroutine demo foo
+ rename foo {}
+} {}
+
+test coroutine-7.7 {Bug 2486550} -setup {
+ interp hide {} yield
+} -body {
+ coroutine demo interp invokehidden {} yield ok
+} -cleanup {
+ demo
+ interp expose {} yield
+} -result ok
+
# cleanup
unset lambda
diff --git a/tests/error.test b/tests/error.test
index 06f8eca..0de644c 100644
--- a/tests/error.test
+++ b/tests/error.test
@@ -182,6 +182,16 @@ test error-4.7 {errorstack via options dict } -body {
catch {f 12} m d
dict get $d -errorstack
} -match glob -result {INNER * CALL {g 1212} CALL {f 12} UP 1}
+test error-4.8 {errorstack from exec traces} -body {
+ proc foo args {}
+ proc goo {} foo
+ trace add execution foo enter {error bar;#}
+ catch goo m d
+ dict get $d -errorstack
+} -cleanup {
+ rename goo {}; rename foo {}
+ unset -nocomplain m d
+} -result {INNER {error bar} CALL goo UP 1}
# Errors in error command itself
diff --git a/tests/interp.test b/tests/interp.test
index 0af9887..ad99fac 100644
--- a/tests/interp.test
+++ b/tests/interp.test
@@ -1599,6 +1599,20 @@ test interp-20.50 {Bug 2486550} -setup {
} -cleanup {
interp delete slave
} -returnCodes error -match glob -result *
+test interp-20.50.1 {Bug 2486550} -setup {
+ interp create slave
+} -body {
+ slave hide coroutine
+ catch {slave invokehidden coroutine} m o
+ dict get $o -errorinfo
+} -cleanup {
+ unset -nocomplain m 0
+ interp delete slave
+} -returnCodes ok -result {wrong # args: should be "coroutine name cmd ?arg ...?"
+ while executing
+"coroutine"
+ invoked from within
+"slave invokehidden coroutine"}
test interp-21.1 {interp hidden} {
interp hidden {}
diff --git a/tests/misc.test b/tests/misc.test
index 6ddc718..d4ece74 100644
--- a/tests/misc.test
+++ b/tests/misc.test
@@ -59,12 +59,7 @@ test misc-1.2 {error in variable ref. in command in array reference} {
missing close-brace for variable name
missing close-brace for variable name
while executing
-"set tst $a([winfo name $\{zz)
- # this is a bogus comment
- # this is a bogus comment
- # this is a bogus comment
- # this is a bogus comment
- # this is a ..."
+"set tst $a([winfo name $\{"
(procedure "tstProc" line 4)
invoked from within
"tstProc"}]
diff --git a/tests/oo.test b/tests/oo.test
index 49fe150..e0e0791 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -936,6 +936,69 @@ test oo-6.18 {Bug 3408830: more forwarding cases} -setup {
} -returnCodes error -cleanup {
fooClass destroy
} -result {wrong # args: should be "::foo len string"}
+test oo-6.19 {Bug 3610404: forwarding resolution + traces} -setup {
+ oo::object create foo
+ unset -nocomplain ::result
+ set ::result {}
+} -body {
+ proc ::my {method} {lappend ::result global}
+ oo::objdefine foo {
+ method target {} {lappend ::result instance}
+ forward bar my target
+ method bump {} {
+ set ns [info object namespace ::foo]
+ rename ${ns}::my ${ns}::
+ rename ${ns}:: ${ns}::my
+ }
+ }
+ proc harness {} {
+ foo target
+ foo bar
+ foo target
+ }
+ trace add execution harness enterstep {apply {{cmd args} {foo bump}}}
+ foo target
+ foo bar
+ foo bump
+ foo bar
+ harness
+} -cleanup {
+ catch {rename harness {}}
+ catch {rename ::my {}}
+ foo destroy
+} -result {instance instance instance instance instance instance}
+test oo-6.20 {Bug 3610404: forwarding resolution + traces} -setup {
+ oo::class create fooClass
+ fooClass create foo
+ unset -nocomplain ::result
+ set ::result {}
+} -body {
+ proc ::my {method} {lappend ::result global}
+ oo::define fooClass {
+ method target {} {lappend ::result class}
+ forward bar my target
+ method bump {} {
+ set ns [info object namespace [self]]
+ rename ${ns}::my ${ns}::
+ rename ${ns}:: ${ns}::my
+ }
+ }
+ proc harness {} {
+ foo target
+ foo bar
+ foo target
+ }
+ trace add execution harness enterstep {apply {{cmd args} {foo bump}}}
+ foo target
+ foo bar
+ foo bump
+ foo bar
+ harness
+} -cleanup {
+ catch {rename harness {}}
+ catch {rename ::my {}}
+ fooClass destroy
+} -result {class class class class class class}
test oo-7.1 {OO: inheritance 101} -setup {
oo::class create superClass
@@ -3374,6 +3437,42 @@ test oo-34.8 {TIP 380: slots - presence} {
test oo-34.9 {TIP 380: slots - presence} {
getMethods oo::objdefine::variable
} {{-append -clear -set} {Get Set}}
+
+test oo-35.1 {Bug 9d61624b3d: Empty superclass must not cause crash} -setup {
+ oo::class create fruit {
+ method eat {} {}
+ }
+ set result {}
+} -body {
+ lappend result [fruit create ::apple] [info class superclasses fruit]
+ oo::define fruit superclass
+ lappend result [info class superclasses fruit] \
+ [info object class apple oo::object] \
+ [info class call fruit destroy] \
+ [catch { apple }]
+} -cleanup {
+ unset -nocomplain result
+ fruit destroy
+} -result {::apple ::oo::object ::oo::object 1 {{method destroy ::oo::object {core method: "destroy"}}} 1}
+test oo-35.2 {Bug 9d61624b3d: Empty superclass must not cause crash} -setup {
+ oo::class create fruitMetaclass {
+ superclass oo::class
+ method eat {} {}
+ }
+ set result {}
+} -body {
+ lappend result [fruitMetaclass create ::appleClass] \
+ [appleClass create orange] \
+ [info class superclasses fruitMetaclass]
+ oo::define fruitMetaclass superclass
+ lappend result [info class superclasses fruitMetaclass] \
+ [info object class appleClass oo::class] \
+ [catch { orange }] [info object class orange] \
+ [appleClass create pear]
+} -cleanup {
+ unset -nocomplain result
+ fruitMetaclass destroy
+} -result {::appleClass ::orange ::oo::class ::oo::class 1 1 ::appleClass ::pear}
cleanupTests
return
diff --git a/tests/parse.test b/tests/parse.test
index b9cfe80..01443c9 100644
--- a/tests/parse.test
+++ b/tests/parse.test
@@ -27,6 +27,7 @@ testConstraint testparsevar [llength [info commands testparsevar]]
testConstraint testasync [llength [info commands testasync]]
testConstraint testcmdtrace [llength [info commands testcmdtrace]]
testConstraint testevent [llength [info commands testevent]]
+testConstraint memory [llength [info commands memory]]
test parse-1.1 {Tcl_ParseCommand procedure, computing string length} testparser {
testparser [bytestring "foo\0 bar"] -1
@@ -678,6 +679,26 @@ test parse-13.5 {Tcl_ParseVar procedure, error looking up variable} testparsevar
unset -nocomplain abc
list [catch {testparsevar {$abc([bogus x y z])}} msg] $msg
} {1 {invalid command name "bogus"}}
+test parse-13.6 {Tcl_ParseVar memory leak} -constraints memory -setup {
+ proc getbytes {} {
+ return [lindex [split [memory info] \n] 3 3]
+ }
+} -body {
+ set a() foo
+ set end [getbytes]
+ for {set i 0} {$i < 5} {incr i} {
+ set vn {}
+ set res [testparsevar [append vn $ a([string repeat {[]} 19]) bar]]
+ if {$res ne {foo bar}} {error "Unexpected result: $res"}
+
+ set tmp $end
+ set end [getbytes]
+ }
+ expr {$end - $tmp}
+} -cleanup {
+ unset -nocomplain a end i vn res tmp
+ rename getbytes {}
+} -result 0
test parse-14.1 {Tcl_ParseBraces procedure, computing string length} testparser {
testparser [bytestring "foo\0 bar"] -1
@@ -1097,6 +1118,12 @@ test parse-21.0 {Bug 1884496} testevent {
testevent queue a head $::script
vwait done
} {}
+test parse-21.1 {TCL_EVAL_DIRECT coverage} testevent {
+ testevent queue a head {testevent delete a; \
+ set ::done [dict get [info frame 0] line]}
+ vwait done
+ set ::done
+} 2
cleanupTests
}
diff --git a/tests/reg.test b/tests/reg.test
index 559f549..e6ce42c 100644
--- a/tests/reg.test
+++ b/tests/reg.test
@@ -1155,6 +1155,9 @@ test reg-33.15 {Bug 3603557 - an "in the wild" RE} {
(.*) # ConditionalFields
}] 0
} 68
+test reg-33.16 {Bug [8d2c0da36d]- another "in the wild" RE} {
+ lindex [regexp -about "^MRK:client1: =1339 14HKelly Talisman 10011000 (\[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]*) \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 8 0 8 0 0 0 77 77 1 1 2 0 11 { 1 3 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 13HC6 My Creator 2 3 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 31HC7 Slightly offensive name, huh 3 8 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 23HE-mail:kelly@hotbox.com 4 9 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 17Hcompface must die 5 10 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 0 3HAir 6 12 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 14HPGP public key 7 13 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 16Hkelly@hotbox.com 8 30 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 0 12H2 text/plain 9 30 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 0 13H2 x-kom/basic 10 33 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 1H0 11 14 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 1H3 }\r?"] 0
+} 1
# cleanup
::tcltest::cleanupTests
diff --git a/tests/regexp.test b/tests/regexp.test
index 1c30001..1b2bec9 100644
--- a/tests/regexp.test
+++ b/tests/regexp.test
@@ -876,6 +876,10 @@ test regexp-22.5 {Bug 3610026} -setup {
} -cleanup {
unset -nocomplain e cp
} -returnCodes error -match glob -result {*too many colors*}
+test regexp-22.6 {Bug 6585b21ca8} {
+ expr {[regexp {(\w).*?\1} Programmer m] ? $m : "<NONE>"}
+} rogr
+
test regexp-23.1 {regexp -all and -line} {
set string ""
diff --git a/tests/rename.test b/tests/rename.test
index 1fa0441..ebf5425 100644
--- a/tests/rename.test
+++ b/tests/rename.test
@@ -140,6 +140,13 @@ test rename-4.7 {reentrancy issues with command deletion and renaming} testdel {
if {[info exists env(value)]} {
unset env(value)
}
+test rename-4.8 {Bug a16752c252} testdel {
+ set x broken
+ testdel {} foo {set x ok}
+ proc foo args {}
+ rename foo {}
+ return -level 0 $x[unset x]
+} ok
# Save the unknown procedure which is modified by the following test.
diff --git a/tests/safe.test b/tests/safe.test
index 4a2792e..859f352 100644
--- a/tests/safe.test
+++ b/tests/safe.test
@@ -425,6 +425,19 @@ test safe-10.1 {testing statics loading} -constraints TcltestPackage -setup {
} -returnCodes error -cleanup {
safe::interpDelete $i
} -result {can't use package in a safe interpreter: no Safepkg1_SafeInit procedure}
+test safe-10.1.1 {testing statics loading} -constraints TcltestPackage -setup {
+ set i [safe::interpCreate]
+} -body {
+ catch {interp eval $i {load {} Safepkg1}} m o
+ dict get $o -errorinfo
+} -returnCodes ok -cleanup {
+ unset -nocomplain m o
+ safe::interpDelete $i
+} -result {can't use package in a safe interpreter: no Safepkg1_SafeInit procedure
+ invoked from within
+"load {} Safepkg1"
+ invoked from within
+"interp eval $i {load {} Safepkg1}"}
test safe-10.2 {testing statics loading / -nostatics} -constraints TcltestPackage -body {
set i [safe::interpCreate -nostatics]
interp eval $i {load {} Safepkg1}
@@ -444,6 +457,18 @@ test safe-10.4 {testing nested statics loading / -nestedloadok} -constraints Tcl
} -returnCodes error -cleanup {
safe::interpDelete $i
} -result {can't use package in a safe interpreter: no Safepkg1_SafeInit procedure}
+test safe-10.4.1 {testing nested statics loading / -nestedloadok} -constraints TcltestPackage -body {
+ set i [safe::interpCreate -nestedloadok]
+ catch {interp eval $i {interp create x; load {} Safepkg1 x}} m o
+ dict get $o -errorinfo
+} -returnCodes ok -cleanup {
+ unset -nocomplain m o
+ safe::interpDelete $i
+} -result {can't use package in a safe interpreter: no Safepkg1_SafeInit procedure
+ invoked from within
+"load {} Safepkg1 x"
+ invoked from within
+"interp eval $i {interp create x; load {} Safepkg1 x}"}
test safe-11.1 {testing safe encoding} -setup {
set i [safe::interpCreate]
@@ -501,6 +526,23 @@ test safe-11.7 {testing safe encoding} -setup {
} -returnCodes error -cleanup {
safe::interpDelete $i
} -result {wrong # args: should be "encoding convertfrom ?encoding? data"}
+test safe-11.7.1 {testing safe encoding} -setup {
+ set i [safe::interpCreate]
+} -body {
+ catch {interp eval $i encoding convertfrom} m o
+ dict get $o -errorinfo
+} -returnCodes ok -cleanup {
+ unset -nocomplain m o
+ safe::interpDelete $i
+} -result {wrong # args: should be "encoding convertfrom ?encoding? data"
+ while executing
+"encoding convertfrom"
+ invoked from within
+"::interp invokehidden interp1 encoding convertfrom"
+ invoked from within
+"encoding convertfrom"
+ invoked from within
+"interp eval $i encoding convertfrom"}
test safe-11.8 {testing safe encoding} -setup {
set i [safe::interpCreate]
} -body {
@@ -508,6 +550,23 @@ test safe-11.8 {testing safe encoding} -setup {
} -returnCodes error -cleanup {
safe::interpDelete $i
} -result {wrong # args: should be "encoding convertto ?encoding? data"}
+test safe-11.8.1 {testing safe encoding} -setup {
+ set i [safe::interpCreate]
+} -body {
+ catch {interp eval $i encoding convertto} m o
+ dict get $o -errorinfo
+} -returnCodes ok -cleanup {
+ unset -nocomplain m o
+ safe::interpDelete $i
+} -result {wrong # args: should be "encoding convertto ?encoding? data"
+ while executing
+"encoding convertto"
+ invoked from within
+"::interp invokehidden interp1 encoding convertto"
+ invoked from within
+"encoding convertto"
+ invoked from within
+"interp eval $i encoding convertto"}
test safe-12.1 {glob is restricted [Bug 2906841]} -setup {
set i [safe::interpCreate]
@@ -715,8 +774,29 @@ test safe-15.1 {safe file ensemble does not surprise code} -setup {
lappend result [catch {interp eval $i {file split a/b/c}} msg] $msg
lappend result [catch {interp eval $i {file isdirectory .}} msg] $msg
} -cleanup {
+ unset -nocomplain msg
interp delete $i
} -result {1 {a b c} 1 {a b c} 1 {invalid command name "file"} 1 0 {a b c} 1 {not allowed to invoke subcommand isdirectory of file}}
+test safe-15.1.1 {safe file ensemble does not surprise code} -setup {
+ set i [interp create -safe]
+} -body {
+ set result [expr {"file" in [interp hidden $i]}]
+ lappend result [interp eval $i {tcl::file::split a/b/c}]
+ lappend result [catch {interp eval $i {tcl::file::isdirectory .}}]
+ lappend result [interp invokehidden $i file split a/b/c]
+ lappend result [catch {interp eval $i {file split a/b/c}} msg] $msg
+ lappend result [catch {interp invokehidden $i file isdirectory .}]
+ interp expose $i file
+ lappend result [catch {interp eval $i {file split a/b/c}} msg] $msg
+ lappend result [catch {interp eval $i {file isdirectory .}} msg o] [dict get $o -errorinfo]
+} -cleanup {
+ unset -nocomplain msg o
+ interp delete $i
+} -result {1 {a b c} 1 {a b c} 1 {invalid command name "file"} 1 0 {a b c} 1 {not allowed to invoke subcommand isdirectory of file
+ while executing
+"file isdirectory ."
+ invoked from within
+"interp eval $i {file isdirectory .}"}}
### ~ should have no special meaning in paths in safe interpreters
test safe-16.1 {Bug 3529949: defang ~ in paths} -setup {
diff --git a/tests/subst.test b/tests/subst.test
index 4be4798..7466895 100644
--- a/tests/subst.test
+++ b/tests/subst.test
@@ -293,6 +293,10 @@ test subst-13.1 {Bug 3081065} -setup {
} -cleanup {
removeFile subst13.tcl
}
+test subst-13.2 {Test for segfault} -body {
+ subst {[}
+} -returnCodes error -result * -match glob
+
# cleanup
::tcltest::cleanupTests
diff --git a/tests/trace.test b/tests/trace.test
index a3a5604..d830f3c 100644
--- a/tests/trace.test
+++ b/tests/trace.test
@@ -2661,6 +2661,13 @@ test trace-39.1 {bug #3485022: tracing Bc'ed commands} -setup {
rename dotrace {}
rename foo {}
} -result {3 | 0 1 1}
+
+test trace-40.1 {execution trace errors become command errors} {
+ proc foo args {}
+ trace add execution foo enter {rename foo {}; error bar;#}
+ catch foo m
+ return -level 0 $m[unset m]
+} bar
# Delete procedures when done, so we don't clash with other tests
# (e.g. foobar will clash with 'unknown' tests).
diff --git a/tests/unixForkEvent.test b/tests/unixForkEvent.test
new file mode 100644
index 0000000..120f362
--- /dev/null
+++ b/tests/unixForkEvent.test
@@ -0,0 +1,45 @@
+# This file contains a collection of tests for the procedures in the file
+# tclUnixNotify.c. Sourcing this file into Tcl runs the tests and
+# generates output for errors. No output means no errors were found.
+#
+# Copyright (c) 1995-1997 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.
+
+package require tcltest 2
+namespace import -force ::tcltest::*
+
+testConstraint testfork [llength [info commands testfork]]
+
+# Test if the notifier thread is well initialized in a forked interpreter
+# by Tcl_InitNotifier
+test unixforkevent-1.1 {fork and test writeable event} \
+ -constraints {testfork nonPortable} \
+ -body {
+ set myFolder [makeDirectory unixtestfork]
+ set pid [testfork]
+ if {$pid == 0} {
+ # we are the forked process
+ set result initialized
+ set h [open [file join $myFolder test.txt] w]
+ fileevent $h writable\
+ "set result writable;\
+ after cancel [after 1000 {set result timeout}]"
+ vwait result
+ close $h
+ makeFile $result result.txt $myFolder
+ exit
+ }
+ # we are the original process
+ while {![file readable [file join $myFolder result.txt]]} {}
+ viewFile result.txt $myFolder
+ } \
+ -result {writable} \
+ -cleanup {
+ catch { removeFolder $myFolder }
+ }
+
+::tcltest::cleanupTests
+return
diff --git a/tests/zlib.test b/tests/zlib.test
index c469eea..0712929 100644
--- a/tests/zlib.test
+++ b/tests/zlib.test
@@ -233,7 +233,7 @@ test zlib-8.7 {transformation and fconfigure} -setup {
# Dictionary is that which is proposed _in_ SPDY draft
set spdyHeaders "HTTP/1.0 200 OK\r\nContent-Type: text/html; charset=utf-8\r\nX-Robots-Tag: noarchive\r\nLast-Modified: Tue, 05 Jun 2012 02:43:25 GMT\r\nETag: \"1338864205129|#public|0|en|||0\"\r\nExpires: Tue, 05 Jun 2012 16:17:11 GMT\r\nDate: Tue, 05 Jun 2012 16:17:06 GMT\r\nCache-Control: public, max-age=5\r\nX-Content-Type-Options: nosniff\r\nX-XSS-Protection: 1; mode=block\r\nServer: GSE\r\n"
set spdyDict "optionsgetheadpostputdeletetraceacceptaccept-charsetaccept-encodingaccept-languageauthorizationexpectfromhostif-modified-sinceif-matchif-none-matchif-rangeif-unmodifiedsincemax-forwardsproxy-authorizationrangerefererteuser-agent100101200201202203204205206300301302303304305306307400401402403404405406407408409410411412413414415416417500501502503504505accept-rangesageetaglocationproxy-authenticatepublicretry-afterservervarywarningwww-authenticateallowcontent-basecontent-encodingcache-controlconnectiondatetrailertransfer-encodingupgradeviawarningcontent-languagecontent-lengthcontent-locationcontent-md5content-rangecontent-typeetagexpireslast-modifiedset-cookieMondayTuesdayWednesdayThursdayFridaySaturdaySundayJanFebMarAprMayJunJulAugSepOctNovDecchunkedtext/htmlimage/pngimage/jpgimage/gifapplication/xmlapplication/xhtmltext/plainpublicmax-agecharset=iso-8859-1utf-8gzipdeflateHTTP/1.1statusversionurl"
-test zlib-8.8 {transformtion and fconfigure} -setup {
+test zlib-8.8 {transformation and fconfigure} -setup {
lassign [chan pipe] inSide outSide
} -constraints zlib -body {
zlib push compress $outSide -dictionary $spdyDict
@@ -250,7 +250,7 @@ test zlib-8.8 {transformtion and fconfigure} -setup {
catch {close $outSide}
catch {close $inSide}
} -result {260 222 {need dictionary} {TCL ZLIB NEED_DICT 2381337010} 2381337010}
-test zlib-8.9 {transformtion and fconfigure} -setup {
+test zlib-8.9 {transformation and fconfigure} -setup {
lassign [chan pipe] inSide outSide
set strm [zlib stream decompress]
} -constraints zlib -body {
@@ -267,7 +267,7 @@ test zlib-8.9 {transformtion and fconfigure} -setup {
catch {close $inSide}
catch {$strm close}
} -result {3064818174 358 358}
-test zlib-8.10 {transformtion and fconfigure} -setup {
+test zlib-8.10 {transformation and fconfigure} -setup {
lassign [chan pipe] inSide outSide
} -constraints zlib -body {
zlib push deflate $outSide -dictionary $spdyDict
@@ -276,7 +276,10 @@ test zlib-8.10 {transformtion and fconfigure} -setup {
puts -nonewline $outSide $spdyHeaders
chan pop $outSide
set compressed [read $inSide]
- catch {zlib inflate $compressed} err opt
+ catch {
+ zlib inflate $compressed
+ throw UNREACHABLE "should be unreachable"
+ } err opt
list [string length [zlib deflate $spdyHeaders]] \
[string length $compressed] \
$err [dict get $opt -errorcode]
@@ -284,7 +287,7 @@ test zlib-8.10 {transformtion and fconfigure} -setup {
catch {close $outSide}
catch {close $inSide}
} -result {254 212 {data error} {TCL ZLIB DATA}}
-test zlib-8.11 {transformtion and fconfigure} -setup {
+test zlib-8.11 {transformation and fconfigure} -setup {
lassign [chan pipe] inSide outSide
set strm [zlib stream inflate]
} -constraints zlib -body {
@@ -300,7 +303,7 @@ test zlib-8.11 {transformtion and fconfigure} -setup {
catch {close $inSide}
catch {$strm close}
} -result {358 358}
-test zlib-8.12 {transformtion and fconfigure} -setup {
+test zlib-8.12 {transformation and fconfigure} -setup {
lassign [chan pipe] inSide outSide
set strm [zlib stream compress]
} -constraints zlib -body {
@@ -317,7 +320,7 @@ test zlib-8.12 {transformtion and fconfigure} -setup {
catch {close $inSide}
catch {$strm close}
} -result {358 358 3064818174}
-test zlib-8.13 {transformtion and fconfigure} -setup {
+test zlib-8.13 {transformation and fconfigure} -setup {
lassign [chan pipe] inSide outSide
set strm [zlib stream compress]
} -constraints zlib -body {
@@ -334,7 +337,7 @@ test zlib-8.13 {transformtion and fconfigure} -setup {
catch {close $inSide}
catch {$strm close}
} -result {358 358 3064818174}
-test zlib-8.14 {transformtion and fconfigure} -setup {
+test zlib-8.14 {transformation and fconfigure} -setup {
lassign [chan pipe] inSide outSide
set strm [zlib stream deflate]
} -constraints zlib -body {
@@ -350,7 +353,7 @@ test zlib-8.14 {transformtion and fconfigure} -setup {
catch {close $inSide}
catch {$strm close}
} -result {358 358}
-test zlib-8.15 {transformtion and fconfigure} -setup {
+test zlib-8.15 {transformation and fconfigure} -setup {
lassign [chan pipe] inSide outSide
set strm [zlib stream deflate]
} -constraints zlib -body {
generated by cgit v0.12 at 2024-11-22 03:45:54 (GMT)