#!/usr/bin/tclsh

# Object persistence with the 'write_objects' function.

# This file now only contains the "library" of apple methods.
# See 'write_apples.tcl' and 'read_apples.tcl' to see how this
# library is used.

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"
      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"
   }
}

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
   }
}

proc write_objects {classname args} {
   foreach name $args {
      upvar #0 $name arr
      puts "$classname $name \\"
      foreach attr [array names arr] {
         puts "   -$attr $arr($attr) \\"
      }
      puts ""
   }
}