summaryrefslogtreecommitdiffstats
path: root/tests
diff options
context:
space:
mode:
Diffstat (limited to 'tests')
-rw-r--r--tests/cmdAH.test2
-rw-r--r--tests/fCmd.test7
-rw-r--r--tests/fileName.test2
-rw-r--r--tests/oo.test100
-rw-r--r--tests/registry.test4
-rw-r--r--tests/util.test45
-rw-r--r--tests/winDde.test4
-rw-r--r--tests/winFCmd.test5
8 files changed, 152 insertions, 17 deletions
diff --git a/tests/cmdAH.test b/tests/cmdAH.test
index 0377064..e8933d6 100644
--- a/tests/cmdAH.test
+++ b/tests/cmdAH.test
@@ -23,7 +23,7 @@ testConstraint testsetplatform [llength [info commands testsetplatform]]
testConstraint testvolumetype [llength [info commands testvolumetype]]
testConstraint linkDirectory [expr {
![testConstraint win] ||
- ([string index $tcl_platform(osVersion) 0] >= 5
+ ($::tcl_platform(osVersion) >= 5.0
&& [lindex [file system [temporaryDirectory]] 1] eq "NTFS")
}]
diff --git a/tests/fCmd.test b/tests/fCmd.test
index 709bfb4..87134d2 100644
--- a/tests/fCmd.test
+++ b/tests/fCmd.test
@@ -65,8 +65,7 @@ if {[testConstraint unix]} {
# Also used in winFCmd...
if {[testConstraint win]} {
- set major [string index $tcl_platform(osVersion) 0]
- if {$major > 5} {
+ if {$::tcl_platform(osVersion) >= 5.0} {
testConstraint winVista 1
} else {
testConstraint winXP 1
@@ -76,7 +75,7 @@ if {[testConstraint win]} {
testConstraint darwin9 [expr {
[testConstraint unix]
&& $tcl_platform(os) eq "Darwin"
- && [package vsatisfies 1.$tcl_platform(osVersion) 1.9]
+ && [package vsatisfies 1.$::tcl_platform(osVersion) 1.9]
}]
testConstraint notDarwin9 [expr {![testConstraint darwin9]}]
@@ -2307,7 +2306,7 @@ test fCmd-27.6 {TclFileAttrsCmd - setting more than one option} -setup {
if {
[testConstraint win] &&
- ([string index $tcl_platform(osVersion) 0] < 5
+ ($::tcl_platform(osVersion) < 5.0
|| [lindex [file system [temporaryDirectory]] 1] ne "NTFS")
} then {
testConstraint linkDirectory 0
diff --git a/tests/fileName.test b/tests/fileName.test
index 7f983a7..7b51da1 100644
--- a/tests/fileName.test
+++ b/tests/fileName.test
@@ -23,7 +23,7 @@ testConstraint testtranslatefilename [llength [info commands testtranslatefilena
testConstraint linkDirectory 1
testConstraint symbolicLinkFile 1
if {[testConstraint win]} {
- if {[string index $tcl_platform(osVersion) 0] < 5 \
+ if {$::tcl_platform(osVersion) < 5.0 \
|| [lindex [file system [temporaryDirectory]] 1] ne "NTFS"} {
testConstraint linkDirectory 0
}
diff --git a/tests/oo.test b/tests/oo.test
index 4e50904..37c4495 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -1802,6 +1802,106 @@ test oo-13.4 {OO: changing an object's class} -body {
foo destroy
bar destroy
} -result {::foo ::foo ::foo ::bar}
+test oo-13.5 {OO: changing an object's class: non-class to class} -setup {
+ oo::object create fooObj
+} -body {
+ oo::objdefine fooObj {
+ class oo::class
+ }
+ oo::define fooObj {
+ method x {} {expr 1+2+3}
+ }
+ [fooObj new] x
+} -cleanup {
+ fooObj destroy
+} -result 6
+test oo-13.6 {OO: changing an object's class: class to non-class} -setup {
+ oo::class create foo
+ unset -nocomplain ::result
+} -body {
+ set result dangling
+ oo::define foo {
+ method x {} {expr 1+2+3}
+ }
+ oo::class create boo {
+ superclass foo
+ destructor {set ::result "ok"}
+ }
+ boo new
+ foo create bar
+ oo::objdefine foo {
+ class oo::object
+ }
+ list $result [catch {bar x} msg] $msg
+} -cleanup {
+ catch {bar destroy}
+ foo destroy
+} -result {ok 1 {invalid command name "bar"}}
+test oo-13.7 {OO: changing an object's class} -setup {
+ oo::class create foo
+ oo::class create bar
+ unset -nocomplain result
+} -body {
+ oo::define bar method x {} {return ok}
+ oo::define foo {
+ method x {} {expr 1+2+3}
+ self mixin foo
+ }
+ lappend result [foo x]
+ oo::objdefine foo class bar
+ lappend result [foo x]
+} -cleanup {
+ foo destroy
+ bar destroy
+} -result {6 ok}
+test oo-13.8 {OO: changing an object's class to itself} -setup {
+ oo::class create foo
+} -body {
+ oo::define foo {
+ method x {} {expr 1+2+3}
+ }
+ oo::objdefine foo class foo
+} -cleanup {
+ foo destroy
+} -returnCodes error -result {may not change classes into an instance of themselves}
+test oo-13.9 {OO: changing an object's class: roots are special} -setup {
+ set i [interp create]
+} -body {
+ $i eval {
+ oo::objdefine oo::object {
+ class oo::class
+ }
+ }
+} -cleanup {
+ interp delete $i
+} -returnCodes error -result {may not modify the class of the root object class}
+test oo-13.10 {OO: changing an object's class: roots are special} -setup {
+ set i [interp create]
+} -body {
+ $i eval {
+ oo::objdefine oo::class {
+ class oo::object
+ }
+ }
+} -cleanup {
+ interp delete $i
+} -returnCodes error -result {may not modify the class of the class of classes}
+test oo-13.11 {OO: changing an object's class in a tricky place} -setup {
+ oo::class create cls
+ unset -nocomplain result
+} -body {
+ set result gorp
+ list [catch {
+ oo::define cls {
+ method x {} {return}
+ self class oo::object
+ ::set ::result ok
+ method y {} {return}; # I'm sorry, Dave. I'm afraid I can't do that.
+ }
+ } msg] $msg $result
+} -cleanup {
+ cls destroy
+} -result {1 {attempt to misuse API} ok}
# todo: changing a class subtype (metaclass) to another class subtype
test oo-14.1 {OO: mixins} {
diff --git a/tests/registry.test b/tests/registry.test
index fec4cc0..539ba2d 100644
--- a/tests/registry.test
+++ b/tests/registry.test
@@ -19,7 +19,7 @@ testConstraint reg 0
if {[testConstraint win]} {
if {![catch {
::tcltest::loadTestedCommands
- set ::regver [package require registry 1.3.2]
+ set ::regver [package require registry 1.3.3]
}]} {
testConstraint reg 1
}
@@ -33,7 +33,7 @@ testConstraint english [expr {
test registry-1.0 {check if we are testing the right dll} {win reg} {
set ::regver
-} {1.3.2}
+} {1.3.3}
test registry-1.1 {argument parsing for registry command} {win reg} {
list [catch {registry} msg] $msg
} {1 {wrong # args: should be "registry ?-32bit|-64bit? option ?arg ...?"}}
diff --git a/tests/util.test b/tests/util.test
index 34113c0..5079a89 100644
--- a/tests/util.test
+++ b/tests/util.test
@@ -586,14 +586,14 @@ test util-9.2.1 {TclGetIntForIndex} -body {
test util-9.2.2 {TclGetIntForIndex} -body {
string index abcd {end }
} -returnCodes error -match glob -result *
-test util-9.3 {TclGetIntForIndex} {
+test util-9.3 {TclGetIntForIndex} -body {
# Deprecated
string index abcd en
-} d
-test util-9.4 {TclGetIntForIndex} {
+} -returnCodes error -match glob -result *
+test util-9.4 {TclGetIntForIndex} -body {
# Deprecated
string index abcd e
-} d
+} -returnCodes error -match glob -result *
test util-9.5.0 {TclGetIntForIndex} {
string index abcd end-1
} c
@@ -735,6 +735,43 @@ test util-9.45 {TclGetIntForIndex} {
test util-9.46 {TclGetIntForIndex} {
string index abcd end+4294967294
} {}
+# TIP 502
+test util-9.47 {TclGetIntForIndex} {
+ string index abcd 0x10000000000000000
+} {}
+test util-9.48 {TclGetIntForIndex} {
+ string index abcd -0x10000000000000000
+} {}
+test util-9.49 {TclGetIntForIndex} -body {
+ string index abcd end*1
+} -returnCodes error -match glob -result *
+test util-9.50 {TclGetIntForIndex} -body {
+ string index abcd {end- 1}
+} -returnCodes error -match glob -result *
+test util-9.51 {TclGetIntForIndex} -body {
+ string index abcd end-end
+} -returnCodes error -match glob -result *
+test util-9.52 {TclGetIntForIndex} -body {
+ string index abcd end-x
+} -returnCodes error -match glob -result *
+test util-9.53 {TclGetIntForIndex} -body {
+ string index abcd end-0.1
+} -returnCodes error -match glob -result *
+test util-9.54 {TclGetIntForIndex} {
+ string index abcd end-0x10000000000000000
+} {}
+test util-9.55 {TclGetIntForIndex} {
+ string index abcd end+0x10000000000000000
+} {}
+test util-9.56 {TclGetIntForIndex} {
+ string index abcd end--0x10000000000000000
+} {}
+test util-9.57 {TclGetIntForIndex} {
+ string index abcd end+-0x10000000000000000
+} {}
+test util-9.58 {TclGetIntForIndex} {
+ string index abcd end--0x8000000000000000
+} {}
test util-10.1 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
convertDouble 0x0000000000000000
diff --git a/tests/winDde.test b/tests/winDde.test
index f04fb45..1fa7e86 100644
--- a/tests/winDde.test
+++ b/tests/winDde.test
@@ -20,7 +20,7 @@ testConstraint dde 0
if {[testConstraint win]} {
if {![catch {
::tcltest::loadTestedCommands
- set ::ddever [package require dde 1.4.0]
+ set ::ddever [package require dde 1.4.1]
set ::ddelib [lindex [package ifneeded dde $::ddever] 1]}]} {
testConstraint dde 1
}
@@ -104,7 +104,7 @@ proc createChildProcess {ddeServerName args} {
# -------------------------------------------------------------------------
test winDde-1.0 {check if we are testing the right dll} {win dde} {
set ::ddever
-} {1.4.0}
+} {1.4.1}
test winDde-1.1 {Settings the server's topic name} -constraints dde -body {
list [dde servername foobar] [dde servername] [dde servername self]
diff --git a/tests/winFCmd.test b/tests/winFCmd.test
index 1767712..a0b7053 100644
--- a/tests/winFCmd.test
+++ b/tests/winFCmd.test
@@ -56,10 +56,9 @@ proc cleanup {args} {
}
if {[testConstraint win]} {
- set major [string index $tcl_platform(osVersion) 0]
- if {$major > 5} {
+ if {$::tcl_platform(osVersion) >= 5.0} {
testConstraint winVista 1
- } elseif {$major == 5} {
+ } else {
testConstraint winXP 1
}
}
generated by cgit v0.12 at 2025-04-18 23:30:03 (GMT)