#!/usr/bin/tclsh

# This is the same as the previous example, but we now use
# a simple template technique to avoid backslash mayhem.

# 'delete' procedure independent of the class
proc delete {args} {
   foreach name $args {
      upvar #0 $name arr
      unset arr        ; # Deletes the object's data
      rename $name {}  ; # Deletes the object command
   }
}

proc class {classname vars methods} {

   # Create the class command, which will allow new instances to be created.
   set template {
      proc @classname@ {obj_name args} {
         # The class command in turn creates an object command.
         # Fewer escape characters thanks to the '@' sign.
         proc $obj_name {command args} \
            "return \[eval dispatch_@classname@ $obj_name \$command \$args\]"

         # Set variable defaults
         upvar #0 $obj_name arr
         array set arr {@vars@}

         # Then possibly override those defaults with user-supplied values
         if { [llength $args] > 0 } {
            eval $obj_name configure $args
         }
      }
   }

   regsub -all @classname@ $template $classname template
   regsub -all @vars@ $template $vars template

   eval $template

   # Create the dispatcher, which dispatches to one of the class methods
   set template {
      proc dispatch_@classname@ {obj_name command args} {
         upvar #0 $obj_name arr
         if { $command == "configure" || $command == "config" } {
            array set arr $args

         } elseif { $command == "cget" } {
            return $arr([lindex $args 0])

         } else {
            if { [lsearch {@methods@} $command] != -1 } {
               uplevel 1 @classname@_${command} $obj_name $args
            } else {
               puts "Error: Unknown command $command"
            }
         }
      }
   }

   regsub -all @classname@ $template $classname template
   regsub -all @methods@ $template $methods template

   eval $template
}

# Create a class with 3 attributes and a 'byte' method.
class apple {-color green -size 5 -price 10} {byte}
proc apple_byte {self} {
   upvar #0 $self arr
   puts "Taking a byte from apple $self"
   incr arr(-size) -1
   if { $arr(-size) <= 0 } {
      puts "Apple $self now completely eaten!  Deleting it..."
      delete $self
   }
}

# Create a class with 2 attributes and 2 methods.
class fridge {-state closed -label A} {open close}
proc fridge_open {self} {
   upvar #0 $self arr
   if { $arr(-state) == "open" } {
      puts "Fridge $self already open."
   } else {
      set arr(-state) "open"
      puts "Opening fridge $self..."
   }
}

proc fridge_close {self} {
   upvar #0 $self arr
   if { $arr(-state) == "closed" } {
      puts "Fridge $self already closed."
   } else {
      set arr(-state) "closed"
      puts "Closing fridge $self..."
   }
}

apple a1 -size 3
apple a2 -color yellow -size 3

foreach i {1 2 3} {
   a1 byte
   a2 byte
}

fridge f1 -state open
f1 close
f1 close
f1 open
f1 open
f1 close