Posted to tcl by schelte at Mon Apr 07 11:06:08 GMT 2025view raw

  1. namespace eval tproc {
  2. proc check {ns checks} {
  3. set args [info level -1]
  4. foreach {i type} $checks {
  5. if {$i >= [llength $args]} continue
  6. set arg [lindex $args $i]
  7. try {
  8. namespace eval $ns [list tproc::validate::$type $arg]
  9. } trap [list TCL LOOKUP COMMAND tproc::validate::$type] {} {
  10. return -level 2 -code error \
  11. "unknown type: \"$type\""
  12. } on ok {rc} {
  13. if {![string is true $rc]} {
  14. return -level 2 -code error \
  15. "invalid argument: \"$arg\", expected a $type"
  16. }
  17. } on error {msg} {
  18. return -level 2 -code error $msg
  19. }
  20. }
  21. }
  22. }
  23.  
  24. namespace eval tproc::validate {
  25. proc int {val} {::string is integer -strict $val}
  26. proc double {val} {::string is double -strict $val}
  27. proc list {val} {::string is list $val}
  28. }
  29.  
  30. proc tproc {proc args body} {
  31. set args [lmap arg $args {
  32. incr i
  33. lassign [split [lindex $arg 0] :] name type
  34. if {$type ne ""} {
  35. lappend checks $i $type
  36. }
  37. lreplace $arg 0 0 $name
  38. }]
  39. set ns [uplevel 1 {namespace current}]::[namespace qualifiers $proc]
  40. set cmd [list ::tproc::check $ns $checks]
  41. namespace eval $ns [list proc [namespace tail $proc] $args $cmd\n$body]
  42. }
  43.  
  44. # Test
  45. tproc foo {a:int {b:double zzz}} {
  46. return [expr {$a * $b}]
  47. }
  48.  
  49. namespace eval baz {
  50. namespace eval tproc::validate {
  51. proc color {val} {
  52. set colors {red blue green}
  53. if {$val ni $colors} {
  54. error "invalid color, must be one of [join $colors {, }]"
  55. }
  56. }
  57. }
  58. }
  59.  
  60. tproc baz::foo {c:color} {
  61. return "the color is $c"
  62. }
  63.  
  64. tproc oops {c:color} {
  65. return "the color is $c"
  66. }
  67.  
  68. foreach test {
  69. {foo 42 3.14}
  70. {foo 13 xyz}
  71. {foo 99}
  72. {baz::foo red}
  73. {baz::foo yellow}
  74. {oops blue}
  75. } {
  76. set rc [catch $test result]
  77. if {$rc} {
  78. puts "fail: $test -> $result"
  79. } else {
  80. puts "pass: $test -> $result"
  81. }
  82. }
  83.