#!/usr/bin/tclsh

# This is the first example that adds a new class ('fridge').
# We redo all the work for each class.  We'll be smart and
# automate this work in the next example.

# '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 dispatch_apple {obj_name command args} {
   upvar #0 $obj_name arr
   if { $command == "configure" || $command == "config" } {
      # Removed error checking here for clarity
      array set arr $args

   } elseif { $command == "cget" } {
      # Removed error checking here for clarity
      return $arr([lindex $args 0])

   } elseif { $command == "byte" } {
      puts "Taking a byte from apple $obj_name"
      incr arr(-size) -1
      if { $arr(-size) <= 0 } {
         puts "Apple $obj_name now completely eaten!  Deleting it..."
         delete $obj_name
      }

   } else {
      puts "Error: Unknown command $command"
   }
}

proc apple {name args} {
   proc $name {command args} \
      "return \[eval dispatch_apple $name \$command \$args\]"

   # First set some defaults
   upvar #0 $name arr
   array set arr {-color green -size 5 -price 10}

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

# Now we introduce the new class 'fridge'.  We need to give it
# a dispatcher procedure and a class command, similar to those for 'apple':

# Dispatch procedure for class 'fridge'.
proc dispatch_fridge {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])

   } elseif { $command == "open" } {
      if { $arr(-state) == "open" } {
         puts "Fridge $obj_name already open."
      } else {
         set arr(-state) "open"
         puts "Opening fridge $obj_name..."
      }

   } elseif { $command == "close" } {
      if { $arr(-state) == "closed" } {
         puts "Fridge $obj_name already closed."
      } else {
         set arr(-state) "closed"
         puts "Closing fridge $obj_name..."
      }

   } else {
      puts "Error: Unknown command $command"
   }
}

# Class procedure for class 'fridge'.
proc fridge {name args} {
   proc $name {command args} \
      "return \[eval dispatch_fridge $name \$command \$args\]"

   # First set some defaults
   upvar #0 $name arr
   array set arr {-state closed -label A}

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

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