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