Posted to tcl by hypnotoad at Mon Oct 23 18:53:19 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 argdef body} {
  8. if {[catch {dict keys $argdef} argnames]} {
  9. puts $argnames
  10. error "Argument definition is not a well formed dict"
  11. }
  12. set result {}
  13. append result {if {[llength $args]==1} {set argdict [lindex $args 0]} else {set argdict $args}} \n
  14. foreach {field info} $argdict {
  15. set argbody [list if {[dict exists $argdict {@field@}]} {set {@field@} [dict get $argdict {@field@}]}]
  16. set map [list @field@ $field]
  17. if {[dict exists $info mandatory]} {
  18. lappend argbody else {error "@field@ is required"}
  19. } elseif {[dict exists $info default]} {
  20. lappend map @dvalue@ [dict get $info default]
  21. lappend argbody else {set {@field@} {@dvalue@}}
  22. }
  23. append result [string map $map $argbody] \n
  24. }
  25. append result $body
  26. ::proc $name args $result
  27. }
  28. }
  29.  
  30. # Example
  31. nproc newmessage {
  32. subject {mandatory 1}
  33. sender {mandatory 1}
  34. mtime {}
  35. body {}
  36. } {
  37. set auto_reply [subst {To: $sender
  38. Subject: Re: $subject
  39.  
  40. Dear $sender,
  41. Thank you for writing us about $subject}]
  42. if {[dict exists $dictargs mtime]} {
  43. append auto_reply " on [clock format [clock scan $mtime]]"
  44. }
  45. puts $auto_reply
  46. }
  47.