Tcl Source Code

Check-in [6893bec0d9]
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to [email protected]
or submit via the online form by Sep 9.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Tests for abstract and singleton
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | tip-478
Files: files | file ages | folders
SHA3-256: 6893bec0d92bbbeed51ed8d6ad5edb050ca2cd27be0b1c38c5beccd068644b1f
User & Date: dkf 2018-06-28 08:12:07
Context
2018-06-28
10:40
Split out TIP 478 tests into their own file. check-in: 5753c80e0e user: dkf tags: tip-478
08:12
Tests for abstract and singleton check-in: 6893bec0d9 user: dkf tags: tip-478
2018-06-27
07:39
Add better error handling and make the delegation work with cloning. check-in: e9637e3ddc user: dkf tags: tip-478
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to generic/tclOOScript.h.

139
140
141
142
143
144
145
146
147

148
149
150
151
152
153
154
"}\n"

"::oo::class create ::oo::singleton {\n"
"    superclass ::oo::class\n"
"    variable object\n"
"    unexport create createWithNamespace\n"
"    method new args {\n"
"        if {![info exists object]} {\n"
"            set object [next {*}$args]\n"

"        }\n"
"        return $object\n"
"    }\n"
"}\n"

"::oo::class create ::oo::abstract {\n"
"    superclass ::oo::class\n"






|

>







139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
"}\n"

"::oo::class create ::oo::singleton {\n"
"    superclass ::oo::class\n"
"    variable object\n"
"    unexport create createWithNamespace\n"
"    method new args {\n"
"        if {![info exists object] || ![info object isa object $object]} {\n"
"            set object [next {*}$args]\n"
"            ::oo::objdefine $object unexport destroy\n"
"        }\n"
"        return $object\n"
"    }\n"
"}\n"

"::oo::class create ::oo::abstract {\n"
"    superclass ::oo::class\n"

Changes to tests/oo.test.

4888
4889
4890
4891
4892
4893
4894
4895
4896
4897
4898
4899
4900
4901
4902
....
4907
4908
4909
4910
4911
4912
4913



































4914
4915
4916
4917
4918
4919
4920
....
5015
5016
5017
5018
5019
5020
5021























































5022
5023
5024
5025
5026
5027
5028
            next $name $body
        }
    }
    TestClass create okay {} {}
} -cleanup {
    parent destroy
} -result {::okay}
test oo-41.4 {TIP 478: classmethod with three levels} -setup {
    oo::class create parent
} -body {
    oo::class create ActiveRecord {
	superclass parent
        classmethod find args {
	    return "[self] called with arguments: $args"
	}
................................................................................
    oo::class create SubTable {
        superclass Table
    }
    SubTable find foo bar
} -cleanup {
    parent destroy
} -result {::SubTable called with arguments: foo bar}




































test oo-42.1 {TIP 478: callback generation} -setup {
    oo::class create parent
} -body {
    oo::class create c {
	superclass parent
	method CallMe {} { return ok,[self] }
................................................................................
    set o [c new x]
    for {set x 0} {$x < 5} {incr x} {}
    $o count
} -cleanup {
    unset -nocomplain x
    parent destroy
} -result 6























































 
cleanupTests
return

# Local Variables:
# mode: tcl
# End:






|







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







4888
4889
4890
4891
4892
4893
4894
4895
4896
4897
4898
4899
4900
4901
4902
....
4907
4908
4909
4910
4911
4912
4913
4914
4915
4916
4917
4918
4919
4920
4921
4922
4923
4924
4925
4926
4927
4928
4929
4930
4931
4932
4933
4934
4935
4936
4937
4938
4939
4940
4941
4942
4943
4944
4945
4946
4947
4948
4949
4950
4951
4952
4953
4954
4955
....
5050
5051
5052
5053
5054
5055
5056
5057
5058
5059
5060
5061
5062
5063
5064
5065
5066
5067
5068
5069
5070
5071
5072
5073
5074
5075
5076
5077
5078
5079
5080
5081
5082
5083
5084
5085
5086
5087
5088
5089
5090
5091
5092
5093
5094
5095
5096
5097
5098
5099
5100
5101
5102
5103
5104
5105
5106
5107
5108
5109
5110
5111
5112
5113
5114
5115
5116
5117
5118
            next $name $body
        }
    }
    TestClass create okay {} {}
} -cleanup {
    parent destroy
} -result {::okay}
test oo-41.4 {TIP 478: classmethod with several inheritance levels} -setup {
    oo::class create parent
} -body {
    oo::class create ActiveRecord {
	superclass parent
        classmethod find args {
	    return "[self] called with arguments: $args"
	}
................................................................................
    oo::class create SubTable {
        superclass Table
    }
    SubTable find foo bar
} -cleanup {
    parent destroy
} -result {::SubTable called with arguments: foo bar}
test oo-41.5 {TIP 478: classmethod and instances} -setup {
    oo::class create parent
} -body {
    oo::class create ActiveRecord {
	superclass parent
        classmethod find args {
	    return "[self] called with arguments: $args"
	}
    }
    oo::class create Table {
	superclass ActiveRecord
    }
    set t [Table new]
    $t find 1 2 3
} -cleanup {
    parent destroy
} -result {::ActiveRecord called with arguments: 1 2 3}
test oo-41.6 {TIP 478: classmethod and instances} -setup {
    oo::class create parent
} -body {
    oo::class create ActiveRecord {
	superclass parent
        classmethod find args {
	    return "[self] called with arguments: $args"
	}
    }
    oo::class create Table {
	superclass ActiveRecord
	unexport find
    }
    set t [Table new]
    $t find 1 2 3
} -returnCodes error -cleanup {
    parent destroy
} -match glob -result {unknown method "find": must be *}

test oo-42.1 {TIP 478: callback generation} -setup {
    oo::class create parent
} -body {
    oo::class create c {
	superclass parent
	method CallMe {} { return ok,[self] }
................................................................................
    set o [c new x]
    for {set x 0} {$x < 5} {incr x} {}
    $o count
} -cleanup {
    unset -nocomplain x
    parent destroy
} -result 6

test oo-43.1 {TIP 478: class initialisation} -setup {
    oo::class create parent
} -body {
    oo::class create ::cls {
	superclass parent
	initialise {
	    proc foobar {} {return ok}
	}
	method calls {} {
	    list [catch foobar msg] $msg \
		[namespace eval [info object namespace [self class]] foobar]
	}
    }
    [cls new] calls
} -cleanup {
    parent destroy
} -result {1 {invalid command name "foobar"} ok}

test oo-44.1 {TIP 478: singleton} -setup {
    oo::class create parent
} -body {
    oo::singleton create xyz {
	superclass parent
    }
    set x [xyz new]
    set y [xyz new]
    set z [xyz new]
    set code [catch {$x destroy} msg]
    set p [xyz new]
    lappend code $msg [catch {rename $x ""}]
    set q [xyz new]
    string map [list $x ONE $q TWO] [list {*}$code $x $y $z $p $q [xyz new]]
} -cleanup {
    parent destroy
} -result {1 {object "ONE" has no visible methods} 0 ONE ONE ONE ONE TWO TWO}

test oo-45.1 {TIP 478: abstract} -setup {
    oo::class create parent
} -body {
    oo::abstract create xyz {
	superclass parent
	method foo {} {return 123}
    }
    oo::class create pqr {
	superclass xyz
	method bar {} {return 456}
    }
    set codes [list [catch {xyz new}] [catch {xyz create x}] [catch {xyz createWithNamespace x y}]]
    set x [pqr new]
    set y [pqr create ::y]
    lappend codes [$x foo] [$x bar] $y
} -cleanup {
    parent destroy
} -result {1 1 1 123 456 ::y}
 
cleanupTests
return

# Local Variables:
# mode: tcl
# End: