summaryrefslogtreecommitdiffstats
path: root/tests
diff options
context:
space:
mode:
Diffstat (limited to 'tests')
-rw-r--r--tests/all.tcl4
-rw-r--r--tests/assemble.test13
-rw-r--r--tests/dict.test14
-rw-r--r--tests/http.test451
-rw-r--r--tests/httpcookie.test853
-rw-r--r--tests/ioCmd.test6
-rw-r--r--tests/lpop.test140
-rwxr-xr-x[-rw-r--r--]tests/lsetComp.test0
-rwxr-xr-x[-rw-r--r--]tests/notify.test0
-rw-r--r--tests/obj.test1
-rw-r--r--tests/oo.test74
-rw-r--r--tests/source.test11
-rw-r--r--tests/string.test79
-rwxr-xr-x[-rw-r--r--]tests/tcltest.test6
14 files changed, 1613 insertions, 39 deletions
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 {}
diff --git a/tests/assemble.test b/tests/assemble.test
index d7c47a9..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}
@@ -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..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::*
}
@@ -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/http.test b/tests/http.test
index b6a7251..cf30348 100644
--- a/tests/http.test
+++ b/tests/http.test
@@ -82,7 +82,7 @@ if {[catch {package present Thread}] == 0 && [file exists $httpdFile]} {
test http-1.1 {http::config} {
http::config -useragent UserAgent
http::config
-} [list -accept */* -pipeline 1 -postfresh 0 -proxyfilter http::ProxyRequired -proxyhost {} -proxyport {} -repost 0 -urlencoding utf-8 -useragent UserAgent -zip 1]
+} [list -accept */* -cookiejar {} -pipeline 1 -postfresh 0 -proxyfilter http::ProxyRequired -proxyhost {} -proxyport {} -repost 0 -urlencoding utf-8 -useragent UserAgent -zip 1]
test http-1.2 {http::config} {
http::config -proxyfilter
} http::ProxyRequired
@@ -97,10 +97,10 @@ test http-1.4 {http::config} {
set x [http::config]
http::config {*}$savedconf
set x
-} {-accept */* -pipeline 1 -postfresh 0 -proxyfilter myFilter -proxyhost nowhere.come -proxyport 8080 -repost 0 -urlencoding iso8859-1 -useragent {Tcl Test Suite} -zip 1}
+} {-accept */* -cookiejar {} -pipeline 1 -postfresh 0 -proxyfilter myFilter -proxyhost nowhere.come -proxyport 8080 -repost 0 -urlencoding iso8859-1 -useragent {Tcl Test Suite} -zip 1}
test http-1.5 {http::config} -returnCodes error -body {
http::config -proxyhost {} -junk 8080
-} -result {Unknown option -junk, must be: -accept, -pipeline, -postfresh, -proxyfilter, -proxyhost, -proxyport, -repost, -urlencoding, -useragent, -zip}
+} -result {Unknown option -junk, must be: -accept, -cookiejar, -pipeline, -postfresh, -proxyfilter, -proxyhost, -proxyport, -repost, -urlencoding, -useragent, -zip}
test http-1.6 {http::config} -setup {
set oldenc [http::config -urlencoding]
} -body {
@@ -670,6 +670,451 @@ 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 {IDNA package: basics} -returnCodes error -body {
+ ::tcl::idna
+} -result {wrong # args: should be "::tcl::idna subcommand ?arg ...?"}
+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 {IDNA package: basics} -body {
+ ::tcl::idna version
+} -result 1.0
+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 {IDNA package: basics} -returnCodes error -body {
+ ::tcl::idna puny
+} -result {wrong # args: should be "::tcl::idna puny subcommand ?arg ...?"}
+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 {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 {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-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-
+} 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 CHAR}
+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
+} 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 {$}}
+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-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
+} 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
+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}
catch {unset badurl}
diff --git a/tests/httpcookie.test b/tests/httpcookie.test
new file mode 100644
index 0000000..204c263
--- /dev/null
+++ b/tests/httpcookie.test
@@ -0,0 +1,853 @@
+# 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 configure, create, destroy or new}
+test http-cookiejar-2.3 {cookie storage: basics} cookiejar {
+ http::cookiejar configure
+} {-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, -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, -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 {
+ 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 configure -loglevel $old
+} -result {info debug debug error error}
+test http-cookiejar-2.8 {cookie storage: basics} -setup {
+ set old [http::cookiejar configure -loglevel]
+} -constraints cookiejar -body {
+ 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 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 -purgeold]
+} -constraints 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 {
+ 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
+} 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]
+} {configure}
+test http-cookiejar-3.4 {cookie storage: class} 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 {
+ 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-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-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: 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: 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: instance} -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: instance} -setup {
+ http::cookiejar create ::cookiejar
+} -constraints 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 {
+ cookiejar storeCookie {
+ key foo
+ value bar
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ }
+} -cleanup {
+ ::cookiejar destroy
+} -result {}
+test http-cookiejar-4.8 {cookie storage: instance} -setup {
+ http::cookiejar create ::cookiejar
+ oo::objdefine ::cookiejar export Database
+} -constraints cookiejar -body {
+ cookiejar storeCookie {
+ key foo
+ value bar
+ 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: instance} -setup {
+ http::cookiejar create ::cookiejar
+ oo::objdefine ::cookiejar export Database
+} -constraints cookiejar -body {
+ cookiejar storeCookie {
+ key foo
+ value bar
+ 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: instance} -setup {
+ http::cookiejar create ::cookiejar
+} -constraints cookiejar -body {
+ cookiejar storeCookie [dict replace {
+ key foo
+ value bar
+ 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: instance} -setup {
+ http::cookiejar create ::cookiejar
+ oo::objdefine ::cookiejar export Database
+} -constraints cookiejar -body {
+ cookiejar storeCookie [dict replace {
+ key foo
+ value bar
+ 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: instance} -setup {
+ http::cookiejar create ::cookiejar
+ oo::objdefine ::cookiejar export Database
+} -constraints cookiejar -body {
+ cookiejar storeCookie [dict replace {
+ key foo
+ value bar
+ 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: instance} -setup {
+ http::cookiejar create ::cookiejar
+ set result {}
+} -constraints cookiejar -body {
+ lappend result [cookiejar getCookies http www.example.com /]
+ cookiejar storeCookie {
+ key foo
+ value bar
+ 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: instance} -setup {
+ http::cookiejar create ::cookiejar
+ set result {}
+} -constraints cookiejar -body {
+ lappend result [cookiejar getCookies http www.example.com /]
+ cookiejar storeCookie [dict replace {
+ key foo
+ value bar
+ 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: instance} -setup {
+ http::cookiejar create ::cookiejar
+ set result {}
+} -constraints cookiejar -body {
+ lappend result [cookiejar getCookies http www.example.com /]
+ cookiejar storeCookie {
+ key foo
+ value bar
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ }
+ cookiejar storeCookie [dict replace {
+ key foo
+ value bar
+ 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: instance} -setup {
+ http::cookiejar create ::cookiejar
+ set result {}
+} -constraints cookiejar -body {
+ lappend result [cookiejar getCookies http www.example.com /]
+ cookiejar storeCookie {
+ key foo1
+ value bar
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ }
+ cookiejar storeCookie [dict replace {
+ key foo2
+ value bar
+ 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}}
+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 {
+ key foo
+ value bar
+ 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 {
+ key foo
+ value bar
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ }
+ cookiejar storeCookie {
+ key bar
+ value foo
+ 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 {
+ key foo1
+ value bar1
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ }
+ cookiejar storeCookie [dict replace {
+ key foo2
+ value bar2
+ 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 {
+ key foo1
+ value bar1
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ }
+ cookiejar storeCookie {
+ key foo2
+ value bar2
+ 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-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
+ cookiejar forceLoadDomainData
+} -constraints cookiejar -body {
+ cookiejar storeCookie {
+ key foo
+ value bar
+ 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
+ cookiejar forceLoadDomainData
+} -constraints cookiejar -body {
+ cookiejar storeCookie {
+ key foo
+ value bar
+ 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
+ cookiejar forceLoadDomainData
+} -constraints cookiejar -body {
+ cookiejar storeCookie {
+ key foo1
+ value bar
+ secure 0
+ domain com
+ origin www.example.com
+ path /
+ hostonly 1
+ }
+ cookiejar storeCookie {
+ key foo2
+ value bar
+ secure 0
+ domain example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ }
+ cookiejar lookup
+} -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 {
+ key foo
+ value bar1
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ }
+ cookiejar storeCookie {
+ key foo
+ value bar2
+ 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-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
+ 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 {
+ key foo
+ value session
+ secure 0
+ domain www.example.com
+ origin www.example.com
+ path /
+ hostonly 1
+ }
+ values [cookiejar getCookies http www.example.com /]
+ 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}]]
+ values [cookiejar getCookies http www.example.com /]
+ cookiejar storeCookie {
+ key foo
+ value session-global
+ 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 {
+ key foo
+ value go-away
+ 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 {}}
+
+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
+
+# Local variables:
+# mode: tcl
+# End:
diff --git a/tests/ioCmd.test b/tests/ioCmd.test
index 948671e..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::*
}
@@ -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/lpop.test b/tests/lpop.test
new file mode 100644
index 0000000..089299b
--- /dev/null
+++ b/tests/lpop.test
@@ -0,0 +1,140 @@
+# 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 {}
+} -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
+} -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"
+ 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:
diff --git a/tests/lsetComp.test b/tests/lsetComp.test
index 6330de4..6330de4 100644..100755
--- a/tests/lsetComp.test
+++ b/tests/lsetComp.test
diff --git a/tests/notify.test b/tests/notify.test
index d2b9123..d2b9123 100644..100755
--- a/tests/notify.test
+++ b/tests/notify.test
diff --git a/tests/obj.test b/tests/obj.test
index cd33eaa..87c8d08 100644
--- a/tests/obj.test
+++ b/tests/obj.test
@@ -540,7 +540,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-32.1 {freeing very large object trees} {
set x {}
for {set i 0} {$i<100000} {incr i} {
diff --git a/tests/oo.test b/tests/oo.test
index 459db8e..0f8cd47 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 {
@@ -779,6 +779,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: method -export flag} -setup {
+ set o [oo::object new]
+ 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
+ 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]
+ 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]
+ 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 <cloned>, 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]
diff --git a/tests/source.test b/tests/source.test
index 0235bd1..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
}
@@ -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/string.test b/tests/string.test
index a0eaac8..81fe130 100644
--- a/tests/string.test
+++ b/tests/string.test
@@ -515,10 +515,10 @@ test string-6.4.$noComp {string is, too many args} {
} {1 {wrong # args: should be "string is class ?-strict? ?-failindex var? str"}}
test string-6.5.$noComp {string is, class check} {
list [catch {run {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.$noComp {string is, ambiguous class} {
list [catch {run {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.$noComp {string is alpha, all ok} {
run {string is alpha -strict -failindex var abc}
} 1
@@ -2306,6 +2306,7 @@ test string-29.15.$noComp {string cat, efficiency} -setup {
tcl::unsupported::representation [run {string cat $e $f $e $f [list x]}]
} -match glob -result {*no string representation}
}
+
test string-30.1.1.$noComp {[Bug ba921a8d98]: string cat} {
run {string cat [set data [binary format a* hello]] [encoding convertto $data] [unset data]}
} hellohello
@@ -2313,8 +2314,80 @@ test string-30.1.2.$noComp {[Bug ba921a8d98]: inplace cat by subst (compiled to
run {set x "[set data [binary format a* hello]][encoding convertto $data][unset data]"}
} hellohello
-}
+test string-31.1.$noComp {string is dict} {
+ string is dict {a b c d}
+} 1
+test string-31.1a.$noComp {string is dict} {
+ string is dict {a b c}
+} 0
+test string-31.2.$noComp {string is dict} {
+ string is dict "a \{b c"
+} 0
+test string-31.3.$noComp {string is dict} {
+ string is dict {a {b c}d e}
+} 0
+test string-31.4.$noComp {string is dict} {
+ string is dict {}
+} 1
+test string-31.5.$noComp {string is dict} {
+ string is dict -strict {a b c d}
+} 1
+test string-31.5a.$noComp {string is dict} {
+ string is dict -strict {a b c}
+} 0
+test string-31.6.$noComp {string is dict} {
+ string is dict -strict "a \{b c"
+} 0
+test string-31.7.$noComp {string is dict} {
+ string is dict -strict {a {b c}d e}
+} 0
+test string-31.8.$noComp {string is dict} {
+ string is dict -strict {}
+} 1
+test string-31.9.$noComp {string is dict} {
+ set x {}
+ list [string is dict -failindex x {a b c d}] $x
+} {1 {}}
+test string-31.9a.$noComp {string is dict} {
+ set x {}
+ list [string is dict -failindex x {a b c}] $x
+} {0 -1}
+test string-31.10.$noComp {string is dict} {
+ set x {}
+ list [string is dict -failindex x "a \{b c d"] $x
+} {0 2}
+test string-31.10a.$noComp {string is dict} {
+ set x {}
+ list [string is dict -failindex x "a \{b c"] $x
+} {0 2}
+test string-31.11.$noComp {string is dict} {
+ set x {}
+ list [string is dict -failindex x {a b {b c}d e}] $x
+} {0 4}
+test string-31.12.$noComp {string is dict} {
+ set x {}
+ list [string is dict -failindex x {}] $x
+} {1 {}}
+test string-31.13.$noComp {string is dict} {
+ set x {}
+ list [string is dict -failindex x { {b c}d e}] $x
+} {0 2}
+test string-31.14.$noComp {string is dict} {
+ set x {}
+ list [string is dict -failindex x "\uabcd {b c}d e"] $x
+} {0 2}
+test string-31.15.$noComp {string is dict, valid dict} {
+ string is dict {a b c d e f}
+} 1
+test string-31.16.$noComp {string is dict, invalid dict} {
+ string is dict a
+} 0
+test string-31.17.$noComp {string is dict, valid dict packed in invalid dict} {
+ string is dict {{a b c d e f g h}}
+} 0
+}; # foreach noComp {0 1}
+
# cleanup
rename MemStress {}
rename makeByteArray {}
diff --git a/tests/tcltest.test b/tests/tcltest.test
index 1487865..ca720ee 100644..100755
--- 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} \
generated by cgit v0.12 at 2024-11-16 10:59:56 (GMT)