#!/usr/bin/tclsh

# Handling multiple attributes with 'configure' and 'cget'.

proc dispatch {obj_name command args} {
   upvar #0 $obj_name arr
   if { $command == "configure" || $command == "config" } {
      foreach {opt val} $args {
         if { ![regexp {^-(.+)} $opt dummy small_opt] } {
            puts "Wrong option name $opt (ignored)"
         } else {
            set arr($small_opt) $val
         }
      }

   } elseif { $command == "cget" } {
      set opt [lindex $args 0]
      if { ![regexp {^-(.+)} $opt dummy small_opt] } {
         puts "Wrong or missing option name $opt"
         return ""
      }
      return $arr($small_opt)

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

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

# We also change the implementation of the "constructor",
# so that it accepts initializing values for the attributes.
proc apple {name args} {
   proc $name {command args} \
      "return \[eval dispatch $name \$command \$args\]"

   # First set some defaults
   upvar #0 $name arr
   set arr(color) green
   set arr(size) 5
   set arr(price) 10

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

proc delete_apple {args} {
   foreach name $args {
      upvar #0 $name arr
      unset arr        ; # Deletes the object's data
      rename $name {}  ; # Deletes the object command
   }
}

apple a1
apple a2 -color yellow -size 3
apple a3 -color red -price 12
foreach a {a1 a2 a3} {
   foreach attr {color size price} {
      puts "$a has $attr [$a cget -$attr]"
   }
}

a2 byte
a2 byte
a2 byte
delete_apple a1 a3   ; # a2 is already deleted 'cause we have eaten it