examples/ootest.tcl

   1 package require oo
   2
   3 # Create a class, the usual bank account, with two instance variables:
   4 class Account {
   5         balance 0
   6         name "Unknown"
   7 }
   8
   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 ""
  15
  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"
  21         }
  22 }
  23
  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]
  28 }
  29 Account method see {} {
  30         set balance
  31 }
  32 Account method withdraw {amount} {
  33         if {$amount > $balance} {error "Sorry $name, can only withdraw $balance"}
  34         set balance [- $balance $amount]
  35 }
  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]"
  42         }
  43 }
  44
  45 # Now an instance, initialisition some fields
  46 set a [Account new {name "Bob Smith"}]
  47
  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]
  52
  53 # Now object methods
  54 $a deposit 100
  55 puts "deposit 100 -> [$a see]"
  56
  57 $a withdraw 40
  58 puts "withdraw 40 -> [$a see]"
  59
  60 catch {$a withdraw 1000} res
  61 puts "withdraw 1000 -> $res\n"
  62
  63 # Tell me something about the object
  64 $a describe
  65 puts ""
  66
  67 # Now create a new subclass
  68 # Could change the initial balance here too
  69 class CreditAccount Account {
  70         limit -1000
  71 }
  72
  73 CreditAccount method constructor {} {
  74         # Dummy constructor
  75         # If desired, manually invoke the baseclass constructor
  76         super constructor
  77 }
  78
  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]
  83 }
  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"
  90         }
  91 }
  92
  93 puts "---- class CreditAccount ----"
  94 puts "CreditAccount vars=[CreditAccount vars]"
  95 puts "CreditAccount methods=[CreditAccount methods]"
  96 puts ""
  97
  98 puts "---- object CreditAccount ----"
  99 set b [CreditAccount new {name "John White"}]
 100
 101 puts b.vars=[$b vars]
 102 puts b.classname=[$b classname]
 103
 104 puts "initial balance -> [$b see]"
 105 $b deposit 100
 106 puts "deposit 100 -> [$b see]"
 107
 108 $b withdraw 40
 109 puts "withdraw 40 -> [$b see]"
 110
 111 $b withdraw 1000
 112 puts "withdraw 1000 -> [$b see]"
 113 puts ""
 114
 115 # Tell me something about the object
 116 $b describe
 117 puts ""
 118
 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"
 126
 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
 135
 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]
 141                         }
 142                 } on error msg {
 143                         puts "Not an object: $r"
 144                 }
 145         }
 146 }
 147 unset r
 148
 149 # And goodbye
 150 $a destroy
 151
 152 # Let the garbage collection take care of this one
 153 unset b
 154 collect