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
63
64
65
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
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
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
154
155
156
157
158
159
160
161
162
163
164
|
package require oo
# Create a class, the usual bank account, with two instance variables:
class Account {
balance 0
name "Unknown"
}
# We have some class methods predefined
# Note we can call (e.g.) either Account.methods or 'Account methods'
puts "---- class Account ----"
puts "Account vars=[Account vars]"
puts "Account methods=[Account methods]"
puts ""
# Create a constructor that takes a name and an optional balance.
Account method constructor {who {amount 0}} {
if {$amount < 0} {
error "Can't initialise account for $who with a -ve balance"
}
set name $who
set balance $amount
}
# Now flesh out the class with some methods
# Could use 'Account method' here instead
Account method deposit {amount} {
set balance [+ $balance $amount]
}
Account method see {} {
set balance
}
Account method withdraw {amount} {
if {$amount > $balance} {error "Sorry $name, can only withdraw $balance"}
set balance [- $balance $amount]
}
Account method describe {} {
puts "I am object $self of class [$self classname]"
puts "My 'see' method returns [$self see]"
puts "My variables are:"
foreach i [$self vars] {
puts " $i=[set $i]"
}
}
# Since the constructor requires an argument, can't
# not provide them
try {
set a [Account]
} on error msg {
puts "Correctly did not create uninitialised account"
}
# Now an instance, using the constructor for initialisation
set a [Account new "Bob Smith"]
puts "---- object Account ----"
# We can use class methods on the instance too
puts a.vars=[$a vars]
puts a.classname=[$a classname]
# Now object methods
$a deposit 100
puts "deposit 100 -> [$a see]"
$a withdraw 40
puts "withdraw 40 -> [$a see]"
catch {$a withdraw 1000} res
puts "withdraw 1000 -> $res\n"
# Tell me something about the object
$a describe
puts ""
# Now create a new subclass
# Could change the initial balance here too
class CreditAccount Account {
limit -1000
}
CreditAccount method constructor {who {amount 0}} {
# Invoke the baseclass constructor, then
# set the amount, which may be -ve
super constructor $who
set balance $amount
}
# Override the 'withdraw' method to allow overdrawing
CreditAccount method withdraw {amount} {
if {$balance - $amount < $limit} {error "Sorry $name, that would exceed your credit limit of [expr -$limit]"}
set balance [- $balance $amount]
}
# Override the 'describe' method, but invoke the baseclass method first
CreditAccount method describe {} {
# First invoke the base class 'describe'
super describe
if {$balance < 0} {
puts "*** Account is in debit"
}
}
puts "---- class CreditAccount ----"
puts "CreditAccount vars=[CreditAccount vars]"
puts "CreditAccount methods=[CreditAccount methods]"
puts ""
puts "---- object CreditAccount ----"
set b [CreditAccount new "John White" -20]
puts b.vars=[$b vars]
puts b.classname=[$b classname]
puts "initial balance -> [$b see]"
$b deposit 100
puts "deposit 100 -> [$b see]"
$b withdraw 40
puts "withdraw 40 -> [$b see]"
$b withdraw 1000
puts "withdraw 1000 -> [$b see]"
puts ""
# Tell me something about the object
$b describe
puts ""
# 'eval' is similar to 'dict with' for an object, except it operates
# in it's own scope. A list of variables can be imported into the object scope.
# It is useful for ad-hoc operations for which it is not worth defining a method.
set total 0
$a eval total { incr total $balance }
incr total [$b get balance]
puts "Total of accounts [$a get name] and [$b eval {return "$name (Credit Limit: $limit)"}] is: $total"
# Can we find all objects in the system?
# Almost. We can't really distinguish those which aren't real classes.
# This will get all references which aren't simple lambdas.
puts "---- All objects ----"
Account new "Terry Green" 20
set x [Account new -]
lambda {} {dummy}
ref blah blah
foreach r [info references] {
if {[getref $r] ne {}} {
try {
$r eval {
puts [format "Found %14s: Owner: %14s, Balance: %+5d, in object %s" [$self classname] $name $balance $self]
}
} on error msg {
puts "Not an object: $r"
}
}
}
unset r
# And goodbye
$a destroy
# Let the garbage collection take care of this one
unset b
collect
|
