Posted to tcl by hypnotoad at Mon Oct 23 18:22:20 GMT 2017view raw

  1. package provide nproc 0.1
  2.  
  3. if {[info command ::nproc] eq {}} {
  4. ###
  5. # Named Procedures
  6. ###
  7. proc ::nproc {name args} {
  8. lassign [lrange $args end-1 end] argdict body
  9. if {[catch {dict keys $argdict} argnames]} {
  10. puts $argnames
  11. error "Argument list is not a well formed dict"
  12. }
  13. set result {}
  14. if {"-nohelp" ni $args} {
  15. append result [string map [list @data@ $argdict] {if {[llength $args]==0} {return {@data@}}}] \n
  16. }
  17. append result {if {[llength $args]==1} {set argdict [lindex $args 0]} else {set argdict $args}} \n
  18. if {"-strict" in $args} {
  19. append result [string map [list @argnames@ $argnames] {foreach item [dict keys $argdict] { if {$item ni {@argnames@}} {error "Unknown argument $item, valid: @argnames@"} } }] \n
  20. }
  21. foreach {field info} $argdict {
  22. set argbody [list if {[dict exists $argdict {@field@}]} {set {@field@} [dict get $argdict {@field@}]}]
  23. set map [list @field@ $field]
  24. if {[dict exists $info manditory]} {
  25. lappend argbody else {error "@field@ is required"}
  26. } elseif {[dict exists $info default]} {
  27. lappend map @dvalue@ [dict get $info default]
  28. lappend argbody else {set {@field@} {@dvalue@}}
  29. }
  30. append result [string map $map $argbody] \n
  31. }
  32. append result $body
  33. ::proc $name args $result
  34. }
  35. }
  36.