Posted to tcl by hypnotoad at Mon Oct 23 18:22:20 GMT 2017view raw
- package provide nproc 0.1
- if {[info command ::nproc] eq {}} {
- ###
- # Named Procedures
- ###
- proc ::nproc {name args} {
- lassign [lrange $args end-1 end] argdict body
- if {[catch {dict keys $argdict} argnames]} {
- puts $argnames
- error "Argument list is not a well formed dict"
- }
- set result {}
- if {"-nohelp" ni $args} {
- append result [string map [list @data@ $argdict] {if {[llength $args]==0} {return {@data@}}}] \n
- }
- append result {if {[llength $args]==1} {set argdict [lindex $args 0]} else {set argdict $args}} \n
- if {"-strict" in $args} {
- append result [string map [list @argnames@ $argnames] {foreach item [dict keys $argdict] { if {$item ni {@argnames@}} {error "Unknown argument $item, valid: @argnames@"} } }] \n
- }
- foreach {field info} $argdict {
- set argbody [list if {[dict exists $argdict {@field@}]} {set {@field@} [dict get $argdict {@field@}]}]
- set map [list @field@ $field]
- if {[dict exists $info manditory]} {
- lappend argbody else {error "@field@ is required"}
- } elseif {[dict exists $info default]} {
- lappend map @dvalue@ [dict get $info default]
- lappend argbody else {set {@field@} {@dvalue@}}
- }
- append result [string map $map $argbody] \n
- }
- append result $body
- ::proc $name args $result
- }
- }