ObjectProc

Updated Mar 31, 2006 (almost complete rewrite) -George

 array set ::ObjectProc {}
 
 proc ObjectProcInstanceCmd {name _body arglist} {
     global ObjectProc
     set requiredlist [list]
 
     if {[llength $arglist] & 1} {
         return -code error "uneven number of arguments: $arglist"
     }
 
     foreach {arg value} $arglist {
         if {[info exists ObjectProc($name,$arg)]} {
             lappend requiredlist $arg
             set msg($arg) $value
         } elseif {[info exists ObjectProc($name,optional,$arg)]} {
             set msg($arg) $value
         } else {
             return -code error "invalid argument: $arg"
         }
     }
 
     if {[llength $requiredlist] != $ObjectProc($name,numrequired)} {
         return -code error "required number of arguments aren't present.  passed: $requiredlist.   expected $ObjectProc($name,numrequired) arguments."
     }
 
     #
     # Cleanup the state before we eval the body.
     # We do this so that the user code doesn't make
     # any assumptions, or break due to existing variables
     # that user code shouldn't care about.
     #
     unset name
     unset requiredlist
     unset arg
     unset value
     unset arglist
 
 
     if 1 $_body
 }
 
 proc ObjectProc {name argstr _body_ body} {
     global ObjectProc
 
     set ObjectProc($name,numrequired) 0
 
     foreach line [split $argstr \n] {
         set objs [split [string trim $line]]
 
         if {[string is space -strict $objs]} continue
 
         switch -- [llength $objs] {
             1 {
                 set ObjectProc($name,[lindex $objs 0]) required
                 incr ObjectProc($name,numrequired)
             }
 
             2 {
                 set ObjectProc($name,optional,[lindex $objs 0]) [lindex $objs 1]
             }
         }
     }
 
     proc $name args \
         [concat ObjectProcInstanceCmd [list $name $body] \$args]
 }
 
 #Test Code
 
 ObjectProc p {
     -x
     -y
     -text ""
 } body {
     puts "x + y = [expr {$msg(-x) + $msg(-y)}]"
     puts "-text is $msg(-text)"
 }
 
 p -x 1 -y 20 -text "Hello World"
 p -x 5 -y 10 -text Wonderment
 p -y 20 -x 300 -text Hmm
 catch {p -x } err; puts $err
 catch {p -x 123 -text Hey} err; puts $err
 catch {p -y 456 -text Foo} err; puts $err

George Peter Staplin Wed Jun 12, 2002: The code below implements a proc-like command that allows default values for arguments, and type checking of values given to arguments.

Comments and improvements are welcome. Feel free to use it however you want.

  #Updated Oct 2, 2002 with the ability to have typeless args

  proc ObjectProcInstanceCmd {argTable body reqArgs argsPassed} {
    array set msg {}
  
    foreach var $reqArgs {
      upvar $var $var
    }
  
    foreach arg $argTable {
      foreach {theMsg value class} $arg break
      set msg($theMsg) $value
      foreach alias [list nil empty string] {
        if {[string equal $alias $class]} {
          set class none
          break
        }
      } 
      set msg($theMsg,class) $class
    }
  
    foreach {theMsg value} $argsPassed {
      if {[info exists msg($theMsg)] != 1} {
        return -code error "invalid message: $theMsg"
      }
  
      if {[string equal $msg($theMsg,class) "none"] || [string is $msg($theMsg,class) $value]} {
        set msg($theMsg) $value
      } else {
        return -code error "invalid value: $value for message: $theMsg"
      }
    }
  
    eval $body
  }
  
  proc ObjectProc {name reqArgs argStr label body} {
    set argTable [split $argStr \n]
    set i 0
    foreach argSet $argTable {
      if {[string trim $argSet] == ""} {
        set argTable [lreplace $argTable $i $i]
        continue
      }
  
      if {[llength $argSet] != 3} {
        return -code error "received a bad argument table"
      }
      incr i
    }
  
    lappend reqArgs args
    proc $name $reqArgs [concat ObjectProcInstanceCmd [list $argTable $body $reqArgs] \$args]
  }

Test Code

 ObjectProc p {reqArg} {
    -x 1 digit
    -y 20 digit
    -text "" none
  } body {
    puts $reqArg
    puts "x + y = [expr {$msg(-x) + $msg(-y)}]"
    puts "-text is $msg(-text)"
  }
  
  p hi -x 1 -y 20 -text "Hello World"
  p bye -x 5 -text Wonderment

Category Command