merge trunk

2 files changed, 370 insertions, 11 deletions

diff --git a/tests/oo.test b/tests/oo.test
index 67535c9..150bc97 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -131,6 +131,13 @@ test oo-1.4 {basic test of OO functionality} -body {
 test oo-1.5 {basic test of OO functionality} -body {
     oo::object doesnotexist
 } -returnCodes 1 -result {unknown method "doesnotexist": must be create, destroy or new}
+test oo-1.5.1 {basic test of OO functionality} -setup {
+    oo::object create aninstance
+} -returnCodes error -body {
+    aninstance
+} -cleanup {
+    rename aninstance {}
+} -result {wrong # args: should be "aninstance method ?arg ...?"}
 test oo-1.6 {basic test of OO functionality} -setup {
     oo::object create aninstance
 } -body {
@@ -1672,6 +1679,53 @@ test oo-15.5 {OO: class cloning - Bug 3474460} -setup {
 } -cleanup {
     ArbitraryClass destroy
 } -result {a b c}
+test oo-15.6 {OO: object cloning copies namespace contents} -setup {
+    oo::class create ArbitraryClass {export eval}
+} -body {
+    ArbitraryClass create a
+    a eval {proc foo x {
+	variable y
+	return [string repeat $x [incr y]]
+    }}
+    set result [list [a eval {foo 2}] [a eval {foo 3}]]
+    oo::copy a b
+    a eval {rename foo bar}
+    lappend result [b eval {foo 2}] [b eval {foo 3}] [a eval {bar 4}]
+} -cleanup {
+    ArbitraryClass destroy
+} -result {2 33 222 3333 444}
+test oo-15.7 {OO: classes can be cloned anonymously} -setup {
+    oo::class create ArbitraryClassA
+    oo::class create ArbitraryClassB {superclass ArbitraryClassA}
+} -body {
+    info object isa class [oo::copy ArbitraryClassB]
+} -cleanup {
+    ArbitraryClassA destroy
+} -result 1
+test oo-15.8 {OO: intercept object cloning} -setup {
+    oo::class create Foo
+    set result {}
+} -body {
+    oo::define Foo {
+	constructor {msg} {
+	    variable v $msg
+	}
+	method <cloned> {from} {
+	    next $from
+	    lappend ::result cloned $from [self]
+	}
+	method check {} {
+	    variable v
+	    lappend ::result check [self] $v
+	}
+    }
+    Foo create foo ok
+    oo::copy foo bar
+    foo check
+    bar check
+} -cleanup {
+    Foo destroy
+} -result {cloned ::foo ::bar check ::foo ok check ::bar ok}
 
 test oo-16.1 {OO: object introspection} -body {
     info object
@@ -1767,10 +1821,10 @@ test oo-16.11 {OO: object introspection} -setup {
 } -body {
     oo::define foo method spong {} {...}
     oo::objdefine bar method boo {a {b c} args} {the body}
-    list [info object methods bar -all] [info object methods bar -all -private]
+    list [lsort [info object methods bar -all]] [lsort [info object methods bar -all -private]]
 } -cleanup {
     foo destroy
-} -result {{boo destroy spong} {boo destroy eval spong unknown variable varname}}
+} -result {{boo destroy spong} {<cloned> boo destroy eval spong unknown variable varname}}
 test oo-16.12 {OO: object introspection} -setup {
     oo::object create foo
 } -cleanup {
@@ -1851,11 +1905,11 @@ test oo-17.9 {OO: class introspection} -setup {
 	}
     }
     oo::define subfoo method boo {a {b c} args} {the body}
-    list [info class methods subfoo -all] \
-	[info class methods subfoo -all -private]
+    list [lsort [info class methods subfoo -all]] \
+	[lsort [info class methods subfoo -all -private]]
 } -cleanup {
     foo destroy
-} -result {{bar boo destroy} {bar boo destroy eval unknown variable varname}}
+} -result {{bar boo destroy} {<cloned> bar boo destroy eval unknown variable varname}}
 test oo-17.10 {OO: class introspection} -setup {
     oo::class create foo
 } -cleanup {
@@ -2389,7 +2443,7 @@ test oo-22.1 {OO and info frame} -setup {
     list [i level] [i frames] [dict get [c frame] object]
 } -cleanup {
     c destroy
-} -result {1 {{type source line * file * cmd {info frame 0} method frames class ::c level 0} {type source line * file * cmd {info frame 0} method frames object ::i level 0}} ::c}
+} -result {1 {{* cmd {info frame 0} method frames class ::c level 0} {* cmd {info frame 0} method frames object ::i level 0}} ::c}
 test oo-22.2 {OO and info frame: Bug 3001438} -setup {
     oo::class create c
 } -body {
@@ -2460,6 +2514,16 @@ test oo-24.2 {unknown method method - Bug 1965063} -setup {
     }
     obj foo bar
 } -result {unknown method "foo": must be destroy, dummy, dummy2 or unknown}
+test oo-24.3 {unknown method method - absent method name} -setup {
+    set o [oo::object new]
+} -cleanup {
+    $o destroy
+} -body {
+    oo::objdefine $o method unknown args {
+	return "unknown: >>$args<<"
+    }
+    list [$o] [$o foobar] [$o foo bar]
+} -result {{unknown: >><<} {unknown: >>foobar<<} {unknown: >>foo bar<<}}
 
 # Probably need a better set of tests, but this is quite difficult to devise
 test oo-25.1 {call chain caching} -setup {
@@ -2751,6 +2815,87 @@ test oo-27.13 {variables declaration: Bug 3185009: require refcount management}
 } -cleanup {
     foo destroy
 } -result {0 7 1 7 {} 0 1 {can't read "x": no such variable}}
+test oo-27.14 {variables declaration - multiple use} -setup {
+    oo::class create master
+} -cleanup {
+    master destroy
+} -body {
+    oo::class create foo {
+	superclass master
+	variable x
+	variable y
+	method boo {} {
+	    return [incr x],[incr y]
+	}
+    }
+    foo create bar
+    list [bar boo] [bar boo]
+} -result {1,1 2,2}
+test oo-27.15 {variables declaration - multiple use} -setup {
+    oo::class create master
+} -cleanup {
+    master destroy
+} -body {
+    oo::class create foo {
+	superclass master
+	variable
+	variable x y
+	method boo {} {
+	    return [incr x],[incr y]
+	}
+    }
+    foo create bar
+    list [bar boo] [bar boo]
+} -result {1,1 2,2}
+test oo-27.16 {variables declaration - multiple use} -setup {
+    oo::class create master
+} -cleanup {
+    master destroy
+} -body {
+    oo::class create foo {
+	superclass master
+	variable x
+	variable -clear
+	variable y
+	method boo {} {
+	    return [incr x],[incr y]
+	}
+    }
+    foo create bar
+    list [bar boo] [bar boo]
+} -result {1,1 1,2}
+test oo-27.17 {variables declaration - multiple use} -setup {
+    oo::class create master
+} -cleanup {
+    master destroy
+} -body {
+    oo::class create foo {
+	superclass master
+	variable x
+	variable -set y
+	method boo {} {
+	    return [incr x],[incr y]
+	}
+    }
+    foo create bar
+    list [bar boo] [bar boo]
+} -result {1,1 1,2}
+test oo-27.18 {variables declaration - multiple use} -setup {
+    oo::class create master
+} -cleanup {
+    master destroy
+} -body {
+    oo::class create foo {
+	superclass master
+	variable x
+	variable -? y
+	method boo {} {
+	    return [incr x],[incr y]
+	}
+    }
+    foo create bar
+    list [bar boo] [bar boo]
+} -returnCodes error -match glob -result {unknown method "-?": must be *}
 
 # A feature that's not supported because the mechanism may change without
 # warning, but is supposed to work...
@@ -2832,6 +2977,148 @@ test oo-31.2 {Bug 3111059: when objects and coroutines entangle} -setup {
 } -cleanup {
     cls destroy
 } -result {0 {}}
+
+oo::class create SampleSlot {
+    superclass oo::Slot
+    constructor {} {
+	variable contents {a b c} ops {}
+    }
+    method contents {} {variable contents; return $contents}
+    method ops {} {variable ops; return $ops}
+    method Get {} {
+	variable contents
+	variable ops
+	lappend ops [info level] Get
+	return $contents
+    }
+    method Set {lst} {
+	variable contents $lst
+	variable ops
+	lappend ops [info level] Set $lst
+	return
+    }
+}
+
+test oo-32.1 {TIP 380: slots - class test} -setup {
+    SampleSlot create sampleSlot
+} -body {
+    list [info level] [sampleSlot contents] [sampleSlot ops]
+} -cleanup {
+    rename sampleSlot {}
+} -result {0 {a b c} {}}
+test oo-32.2 {TIP 380: slots - class test} -setup {
+    SampleSlot create sampleSlot
+} -body {
+    list [info level] [sampleSlot -clear] \
+	[sampleSlot contents] [sampleSlot ops]
+} -cleanup {
+    rename sampleSlot {}
+} -result {0 {} {} {1 Set {}}}
+test oo-32.3 {TIP 380: slots - class test} -setup {
+    SampleSlot create sampleSlot
+} -body {
+    list [info level] [sampleSlot -append g h i] \
+	[sampleSlot contents] [sampleSlot ops]
+} -cleanup {
+    rename sampleSlot {}
+} -result {0 {} {a b c g h i} {1 Get 1 Set {a b c g h i}}}
+test oo-32.4 {TIP 380: slots - class test} -setup {
+    SampleSlot create sampleSlot
+} -body {
+    list [info level] [sampleSlot -set d e f] \
+	[sampleSlot contents] [sampleSlot ops]
+} -cleanup {
+    rename sampleSlot {}
+} -result {0 {} {d e f} {1 Set {d e f}}}
+test oo-32.5 {TIP 380: slots - class test} -setup {
+    SampleSlot create sampleSlot
+} -body {
+    list [info level] [sampleSlot -set d e f] [sampleSlot -append g h i] \
+	[sampleSlot contents] [sampleSlot ops]
+} -cleanup {
+    rename sampleSlot {}
+} -result {0 {} {} {d e f g h i} {1 Set {d e f} 1 Get 1 Set {d e f g h i}}}
+
+test oo-33.1 {TIP 380: slots - defaulting} -setup {
+    set s [SampleSlot new]
+} -body {
+    list [$s x y] [$s contents]
+} -cleanup {
+    rename $s {}
+} -result {{} {a b c x y}}
+test oo-33.2 {TIP 380: slots - defaulting} -setup {
+    set s [SampleSlot new]
+} -body {
+    list [$s destroy; $s unknown] [$s contents]
+} -cleanup {
+    rename $s {}
+} -result {{} {a b c destroy unknown}}
+test oo-32.3 {TIP 380: slots - defaulting} -setup {
+    set s [SampleSlot new]
+} -body {
+    oo::objdefine $s forward --default-operation  my -set
+    list [$s destroy; $s unknown] [$s contents] [$s ops]
+} -cleanup {
+    rename $s {}
+} -result {{} unknown {1 Set destroy 1 Set unknown}}
+test oo-33.4 {TIP 380: slots - errors} -setup {
+    set s [SampleSlot new]
+} -body {
+    # Method names beginning with "-" are special to slots
+    $s -grill q
+} -returnCodes error -cleanup {
+    rename $s {}
+} -result {unknown method "-grill": must be -append, -clear, -set, contents or ops}
+
+SampleSlot destroy
+
+test oo-34.1 {TIP 380: slots - presence} -setup {
+    set obj [oo::object new]
+    set result {}
+} -body {
+    oo::define oo::object {
+	::lappend ::result [::info object class filter]
+	::lappend ::result [::info object class mixin]
+	::lappend ::result [::info object class superclass]
+	::lappend ::result [::info object class variable]
+    }
+    oo::objdefine $obj {
+	::lappend ::result [::info object class filter]
+	::lappend ::result [::info object class mixin]
+	::lappend ::result [::info object class variable]
+    }
+    return $result
+} -cleanup {
+    $obj destroy
+} -result {::oo::Slot ::oo::Slot ::oo::Slot ::oo::Slot ::oo::Slot ::oo::Slot ::oo::Slot}
+test oo-34.2 {TIP 380: slots - presence} {
+    lsort [info class instances oo::Slot]
+} {::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable}
+proc getMethods obj {
+    list [lsort [info object methods $obj -all]] \
+	[lsort [info object methods $obj -private]]
+}
+test oo-34.3 {TIP 380: slots - presence} {
+    getMethods oo::define::filter
+} {{-append -clear -set} {Get Set}}
+test oo-34.4 {TIP 380: slots - presence} {
+    getMethods oo::define::mixin
+} {{-append -clear -set} {--default-operation Get Set}}
+test oo-34.5 {TIP 380: slots - presence} {
+    getMethods oo::define::superclass
+} {{-append -clear -set} {--default-operation Get Set}}
+test oo-34.6 {TIP 380: slots - presence} {
+    getMethods oo::define::variable
+} {{-append -clear -set} {Get Set}}
+test oo-34.7 {TIP 380: slots - presence} {
+    getMethods oo::objdefine::filter
+} {{-append -clear -set} {Get Set}}
+test oo-34.8 {TIP 380: slots - presence} {
+    getMethods oo::objdefine::mixin
+} {{-append -clear -set} {--default-operation Get Set}}
+test oo-34.9 {TIP 380: slots - presence} {
+    getMethods oo::objdefine::variable
+} {{-append -clear -set} {Get Set}}
 
 cleanupTests
 return
diff --git a/tests/string.test b/tests/string.test
index 85a7372..b3326ae 100644
--- a/tests/string.test
+++ b/tests/string.test
@@ -312,10 +312,10 @@ test string-6.4 {string is, too many args} {
 } {1 {wrong # args: should be "string is class ?-strict? ?-failindex var? str"}}
 test string-6.5 {string is, class check} {
     list [catch {string is bogus str} msg] $msg
-} {1 {bad class "bogus": must be alnum, alpha, ascii, control, boolean, digit, double, 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, digit, double, entier, false, graph, integer, list, lower, print, punct, space, true, upper, wideinteger, wordchar, or xdigit}}
 test string-6.6 {string is, ambiguous class} {
     list [catch {string is al str} msg] $msg
-} {1 {ambiguous class "al": must be alnum, alpha, ascii, control, boolean, digit, double, 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, digit, double, entier, false, graph, integer, list, lower, print, punct, space, true, upper, wideinteger, wordchar, or xdigit}}
 test string-6.7 {string is alpha, all ok} {
     string is alpha -strict -failindex var abc
 } 1
@@ -592,7 +592,7 @@ test string-6.90 {string is integer, bad integers} {
     foreach num $numbers {
 	lappend result [string is int -strict $num]
     }
-    set result
+    return $result
 } {1 1 0 0 0 1 0 0}
 test string-6.91 {string is double, bad doubles} {
     set result ""
@@ -600,7 +600,7 @@ test string-6.91 {string is double, bad doubles} {
     foreach num $numbers {
 	lappend result [string is double -strict $num]
     }
-    set result
+    return $result
 } {1 1 0 0 0 1 0 0}
 test string-6.92 {string is integer, 32-bit overflow} {
     # Bug 718878
@@ -664,7 +664,7 @@ test string-6.107 {string is integer, bad integers} {
     foreach num $numbers {
 	lappend result [string is wideinteger -strict $num]
     }
-    set result
+    return $result
 } {1 1 0 0 0 1 0 0}
 test string-6.108 {string is double, Bug 1382287} {
     set x 2turtledoves
@@ -674,6 +674,78 @@ test string-6.108 {string is double, Bug 1382287} {
 test string-6.109 {string is double, Bug 1360532} {
     string is double 1\u00a0
 } 0
+test string-6.110 {string is entier, true} {
+    string is entier +1234567890
+} 1
+test string-6.111 {string is entier, true on type} {
+    string is entier [expr wide(50.0)]
+} 1
+test string-6.112 {string is entier, true} {
+    string is entier [list -10]
+} 1
+test string-6.113 {string is entier, true as hex} {
+    string is entier 0xabcdef
+} 1
+test string-6.114 {string is entier, true as octal} {
+    string is entier 0123456
+} 1
+test string-6.115 {string is entier, true with whitespace} {
+    string is entier "  \n1234\v"
+} 1
+test string-6.116 {string is entier, false} {
+    list [string is entier -fail var 123abc] $var
+} {0 3}
+test string-6.117 {string is entier, false} {
+    list [string is entier -fail var 123123123123123123123123123123123123123123123123123123123123123123123123123123123123abc] $var
+} {0 84}
+test string-6.118 {string is entier, false} {
+    list [string is entier -fail var [expr double(1)]] $var
+} {0 1}
+test string-6.119 {string is entier, false} {
+    list [string is entier -fail var "    "] $var
+} {0 0}
+test string-6.120 {string is entier, false on bad octal} {
+    list [string is entier -fail var 0o36963] $var
+} {0 4}
+test string-6.121.1 {string is entier, false on bad octal} {
+    list [string is entier -fail var 0o36963] $var
+} {0 4}
+test string-6.122 {string is entier, false on bad hex} {
+    list [string is entier -fail var 0X345XYZ] $var
+} {0 5}
+test string-6.123 {string is entier, bad integers} {
+    # SF bug #634856
+    set result ""
+    set numbers [list 1 +1 ++1 +-1 -+1 -1 --1 "- +1"]
+    foreach num $numbers {
+	lappend result [string is entier -strict $num]
+    }
+    return $result
+} {1 1 0 0 0 1 0 0}
+test string-6.124 {string is entier, true} {
+    string is entier +1234567890123456789012345678901234567890
+} 1
+test string-6.125 {string is entier, true} {
+    string is entier [list -10000000000000000000000000000000000000000000000000000000000000000000000000000000000000]
+} 1
+test string-6.126 {string is entier, true as hex} {
+    string is entier 0xabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdef
+} 1
+test string-6.127 {string is entier, true as octal} {
+    string is entier 0123456112341234561234565623456123456123456123456123456123456123456123456123456123456
+} 1
+test string-6.128 {string is entier, true with whitespace} {
+    string is entier "  \n12340000000000000000000000000000000000000000000000000000000000000000000000000000000000000\v"
+} 1
+test string-6.129 {string is entier, false on bad octal} {
+    list [string is entier -fail var 0o1234561123412345612345656234561234561234561234561234561234561234561234561234561234536963] $var
+} {0 87}
+test string-6.130.1 {string is entier, false on bad octal} {
+    list [string is entier -fail var 0o1234561123412345612345656234561234561234561234561234561234561234561234561234561234536963] $var
+} {0 87}
+test string-6.131 {string is entier, false on bad hex} {
+    list [string is entier -fail var 0X12345611234123456123456562345612345612345612345612345612345612345612345612345612345345XYZ] $var
+} {0 88}
 
 catch {rename largest_int {}}