Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Changes In Branch ooutil-bug-3609183
Excluding Merge-Ins
This is equivalent to a diff from
2847321e30
to d4fbc67d71
|
2014-02-13
| | |
| 06:28 |
|
check-in: 9cefaa3479 user: aku tags: trunk
|
|
2014-02-12
| | |
| 05:53 |
|
check-in: e891598c4c user: aku tags: ftp-bug-eb0b15d598
|
| 05:52 |
|
check-in: 25c175ce82 user: aku tags: update-to-critcl3
|
| 05:52 |
|
Leaf
check-in: d4fbc67d71 user: aku tags: ooutil-bug-3609183
|
|
2014-02-11
| | |
| 19:04 |
|
check-in: 2847321e30 user: aku tags: trunk, release, tcllib-1-16
|
| 18:58 |
|
Closed-Leaf
check-in: 6430a704e6 user: aku tags: tcllib-1-16-rc
|
|
2014-02-04
| | |
| 22:03 |
|
check-in: a5597ab71e user: andreask tags: trunk
|
|
2013-06-05
| | |
| 20:52 |
|
check-in: 4c1ee14d54 user: andreask tags: ooutil-bug-3609183
|
| | |
Changes to modules/devtools/testutilities.tcl.
| ︙ | | |
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
|
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
|
-
+
-
+
-
+
+
-
-
+
+
+
+
+
+
+
+
+
+
-
+
|
puts " Aborting the tests found in [file tail [info script]]."
puts " Requiring at least tcltest $version, have [package present tcltest]"
# This causes a 'return' in the calling scope.
return -code return
}
proc testsNeed {name version} {
proc testsNeed {name args} {
# This command ensures that a minimum version of package <name> is
# used to run the tests in the calling testsuite. If the minimum
# is not met by the active interpreter we forcibly bail out of the
# testsuite calling the command. The command has to be called
# immediately after loading the utilities.
if {[catch {
package require $name $version
package require $name
}]} {
puts " Aborting the tests found in \"[file tail [info script]]\""
puts " Requiring at least $name $version, package not found."
puts " Requiring package $name, not found."
return -code return
}
foreach version $args {
if {[package vsatisfies [package present $name] $version]} return
puts " Requiring at least $name $version, have [package present $name]."
puts " Requiring at least $name $args, have [package present $name]."
# This causes a 'return' in the calling scope.
return -code return
}
# ### ### ### ######### ######### #########
|
| ︙ | | |
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
|
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
|
-
+
-
+
+
|
set use [expr {$acc ? "useKeep" : "use"}]
uplevel 1 [linsert $args 0 $use $fname $pname]
}
proc support {script} {
InitializeTclTest
set ::tcllib::testutils::tag "-"
if {[catch {
if {[set code [catch {
uplevel 1 $script
} msg]} {
} msg]]} {
if {$code == 2} { return -code return }
set prefix "SETUP Error (Support): "
puts $prefix[join [split $::errorInfo \n] "\n$prefix"]
return -code return
}
return
}
|
| ︙ | | |
Changes to modules/ooutil/ooutil.tcl.
| ︙ | | |
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
|
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
|
-
+
-
+
+
-
+
+
|
# ::Table called with arguments: foo bar
# ======
# # ## ### ##### ######## ############# ####################
## Singleton Metaclass
## http://wiki.tcl.tk/21595. v63, Donal Fellows
oo::class create ooutil::singleton {
oo::class create oo::util::singleton {
superclass oo::class
variable object
method create {name args} {
if {![info exists object]} {
if {![info exists object] ||
![info object isa object $object]} {
set object [next $name {*}$args]
}
return $object
}
method new args {
if {![info exists object]} {
if {![info exists object] ||
![info object isa object $object]} {
set object [next {*}$args]
}
return $object
}
}
# ======
|
| ︙ | | |
Added modules/ooutil/ooutil.test.
|
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
# -*- tcl -*-
# # ## ### ##### ######## ############# #####################
## Tests for the oo utilities facility
## Copyright (c) 2012 by ActiveState Tool Corp.
## BSD licensed.
# # ## ### ##### ######## ############# #####################
source [file join \
[file dirname [file dirname [file join [pwd] [info script]]]] \
devtools testutilities.tcl]
testsNeedTcl 8.5
testsNeedTcltest 2
support {
testsNeed TclOO 0.6 1
puts [package ifneeded TclOO [package present TclOO]]
}
testing {
useLocal ooutil.tcl oo::util
}
# # ## ### ##### ######## ############# #####################
test ooutil-singleton-3609183-1 {bug 3609183} -setup {
oo::class create example {
self mixin oo::util::singleton
method foo {} {self}
}
} -body {
set a [[example new] foo]
set b [[example new] foo]
puts $a
puts $b
string equal $a $b
} -cleanup {
unset a b
example destroy
} -result 1
test ooutil-singleton-3609183-2 {bug 3609183} -setup {
oo::util::singleton create example {
method foo {} {self}
}
} -body {
set a [[example new] foo]
set b [[example new] foo]
puts $a
puts $b
string equal $a $b
} -cleanup {
unset a b
example destroy
} -result 1
# # ## ### ##### ######## ############# #####################
testsuiteCleanup
return
|
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | |
