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 # Now flesh out the class with some methods
  17 # Could use 'Account method' here instead
  18 Account method deposit {amount} {
  19         set balance [+ $balance $amount]
  20 }
  21 Account method see {} {
  22         set balance
  23 }
  24 Account method withdraw {amount} {
  25         if {$amount > $balance} {error "Sorry $name, can only withdraw $balance"}
  26         set balance [- $balance $amount]
  27 }
  28 Account method describe {} {
  29         puts "I am object $self of class [$self classname]"
  30         puts "My 'see' method returns [$self see]"
  31         puts "My variables are:"
  32         foreach i [$self vars] {
  33                 puts "  $i=[set $i]"
  34         }
  35 }
  36
  37 # Now an instance, initialisition some fields
  38 set a [Account new {name "Bob Smith"}]
  39
  40 puts "---- object Account ----"
  41 # We can use class methods on the instance too
  42 puts a.vars=[$a vars]
  43 puts a.classname=[$a classname]
  44
  45 # Now object methods
  46 $a deposit 100
  47 puts "deposit 100 -> [$a see]"
  48
  49 $a withdraw 40
  50 puts "withdraw 40 -> [$a see]"
  51
  52 catch {$a withdraw 1000} res
  53 puts "withdraw 1000 -> $res\n"
  54
  55 # Tell me something about the object
  56 $a describe
  57 puts ""
  58
  59 # Now create a new subclass
  60 class CreditAccount Account {
  61         limit -1000
  62         balance -20
  63 }
  64 # Override the 'withdraw' method to allow overdrawing
  65 CreditAccount method withdraw {amount} {
  66         if {$balance - $amount < $limit} {error "Sorry $name, that would exceed your credit limit of [expr -$limit]"}
  67         set balance [- $balance $amount]
  68 }
  69 # Override the 'describe' method, but invoke the baseclass method first
  70 CreditAccount method describe {} {
  71         # First invoke the base class 'describe'
  72         super describe
  73         if {$balance < 0} {
  74                 puts "*** Account is in debit"
  75         }
  76 }
  77
  78 puts "---- class CreditAccount ----"
  79 puts "CreditAccount vars=[CreditAccount vars]"
  80 puts "CreditAccount methods=[CreditAccount methods]"
  81 puts ""
  82
  83 puts "---- object CreditAccount ----"
  84 set b [CreditAccount new {name "John White"}]
  85
  86 puts b.vars=[$b vars]
  87 puts b.classname=[$b classname]
  88
  89 puts "initial balance -> [$b see]"
  90 $b deposit 100
  91 puts "deposit 100 -> [$b see]"
  92
  93 $b withdraw 40
  94 puts "withdraw 40 -> [$b see]"
  95
  96 $b withdraw 1000
  97 puts "withdraw 1000 -> [$b see]"
  98 puts ""
  99
 100 # Tell me something about the object
 101 $b describe
 102 puts ""
 103
 104 # 'eval' is similar to 'dict with' for an object, except it operates
 105 # in it's own scope. A list of variables can be imported into the object scope.
 106 # It is useful for ad-hoc operations for which it is not worth defining a method.
 107 set total 0
 108 $a eval total { incr total $balance }
 109 incr total [$b get balance]
 110 puts "Total of accounts [$a get name] and [$b eval {return "$name (Credit Limit: $limit)"}] is: $total"
 111
 112 # Can we find all objects in the system?
 113 # Almost. We can't really distinguish those which aren't real classes.
 114 # This will get all references which aren't simple lambdas.
 115 puts "---- All objects ----"
 116 Account new {name "Terry Green" balance 20}
 117 set x [Account]
 118 lambda {} {dummy}
 119 ref blah blah
 120
 121 foreach r [info references] {
 122         if {[getref $r] ne {}} {
 123                 try {
 124                         $r eval {
 125                                 puts [format "Found %14s: Owner: %14s, Balance: %+5d, in object %s" [$self classname] $name $balance $self]
 126                         }
 127                 } on error msg {
 128                         puts "Not an object: $r"
 129                 }
 130         }
 131 }
 132 unset r
 133
 134 # And goodbye
 135 $a destroy
 136
 137 # Let the garbage collection take care of this one
 138 unset b
 139 collect