appveyor.yml: update OpenSSL DLL paths
[jimtcl.git] / examples / ootest.tcl
blob731e46a6073bb60c37cce4b4bcfad4ad4ef4d708
1 package require oo
3 # Create a class, the usual bank account, with two instance variables:
4 class Account {
5 balance 0
6 name "Unknown"
9 # We have some class methods predefined
10 # Note we can call (e.g.) either Account.methods or 'Account methods'
11 puts "---- class Account ----"
12 puts "Account vars=[Account vars]"
13 puts "Account methods=[Account methods]"
14 puts ""
16 # Create a constructor. This does validation, but it could
17 # do other things
18 Account method constructor {} {
19 if {$balance < 0} {
20 error "Can't initialise account with a -ve balance"
24 # Now flesh out the class with some methods
25 # Could use 'Account method' here instead
26 Account method deposit {amount} {
27 set balance [+ $balance $amount]
29 Account method see {} {
30 set balance
32 Account method withdraw {amount} {
33 if {$amount > $balance} {error "Sorry $name, can only withdraw $balance"}
34 set balance [- $balance $amount]
36 Account method describe {} {
37 puts "I am object $self of class [$self classname]"
38 puts "My 'see' method returns [$self see]"
39 puts "My variables are:"
40 foreach i [$self vars] {
41 puts " $i=[set $i]"
45 # Now an instance, initialisition some fields
46 set a [Account new {name "Bob Smith"}]
48 puts "---- object Account ----"
49 # We can use class methods on the instance too
50 puts a.vars=[$a vars]
51 puts a.classname=[$a classname]
53 # Now object methods
54 $a deposit 100
55 puts "deposit 100 -> [$a see]"
57 $a withdraw 40
58 puts "withdraw 40 -> [$a see]"
60 catch {$a withdraw 1000} res
61 puts "withdraw 1000 -> $res\n"
63 # Tell me something about the object
64 $a describe
65 puts ""
67 # Now create a new subclass
68 # Could change the initial balance here too
69 class CreditAccount Account {
70 limit -1000
73 CreditAccount method constructor {} {
74 # Dummy constructor
75 # If desired, manually invoke the baseclass constructor
76 super constructor
79 # Override the 'withdraw' method to allow overdrawing
80 CreditAccount method withdraw {amount} {
81 if {$balance - $amount < $limit} {error "Sorry $name, that would exceed your credit limit of [expr -$limit]"}
82 set balance [- $balance $amount]
84 # Override the 'describe' method, but invoke the baseclass method first
85 CreditAccount method describe {} {
86 # First invoke the base class 'describe'
87 super describe
88 if {$balance < 0} {
89 puts "*** Account is in debit"
93 puts "---- class CreditAccount ----"
94 puts "CreditAccount vars=[CreditAccount vars]"
95 puts "CreditAccount methods=[CreditAccount methods]"
96 puts ""
98 puts "---- object CreditAccount ----"
99 set b [CreditAccount new {name "John White"}]
101 puts b.vars=[$b vars]
102 puts b.classname=[$b classname]
104 puts "initial balance -> [$b see]"
105 $b deposit 100
106 puts "deposit 100 -> [$b see]"
108 $b withdraw 40
109 puts "withdraw 40 -> [$b see]"
111 $b withdraw 1000
112 puts "withdraw 1000 -> [$b see]"
113 puts ""
115 # Tell me something about the object
116 $b describe
117 puts ""
119 # 'eval' is similar to 'dict with' for an object, except it operates
120 # in it's own scope. A list of variables can be imported into the object scope.
121 # It is useful for ad-hoc operations for which it is not worth defining a method.
122 set total 0
123 $a eval total { incr total $balance }
124 incr total [$b get balance]
125 puts "Total of accounts [$a get name] and [$b eval {return "$name (Credit Limit: $limit)"}] is: $total"
127 # Can we find all objects in the system?
128 # Almost. We can't really distinguish those which aren't real classes.
129 # This will get all references which aren't simple lambdas.
130 puts "---- All objects ----"
131 Account new {name "Terry Green" balance 20}
132 set x [Account]
133 lambda {} {dummy}
134 ref blah blah
136 foreach r [info references] {
137 if {[getref $r] ne {}} {
138 try {
139 $r eval {
140 puts [format "Found %14s: Owner: %14s, Balance: %+5d, in object %s" [$self classname] $name $balance $self]
142 } on error msg {
143 puts "Not an object: $r"
147 unset r
149 # And goodbye
150 $a destroy
152 # Let the garbage collection take care of this one
153 unset b
154 collect