Posted to tcl by aspect at Tue Jul 10 06:42:32 GMT 2007view raw

  1. ## apply.tcl
  2. # from: http://wiki.tcl.tk/4884
  3. proc apply {fun args} {
  4. set len [llength $fun]
  5. if {($len < 2) || ($len > 3)} {
  6. error "can't interpret \"$fun\" as anonymous function"
  7. }
  8. lassign $fun argList body ns
  9. set name ::$ns::[getGloballyUniqueName]
  10. set body0 {
  11. rename [lindex [info level 0] 0] {}
  12. }
  13. proc $name $argList ${body0}$body
  14. set code [catch {uplevel 1 $name $args} res opt]
  15. return -options $opt $res
  16. }
  17.  
  18.  
  19. ## schema.tcl
  20. # source apply.tcl
  21.  
  22. set schema_names(ID) "Reg No"
  23. set schema_names(name) "Name"
  24. set schema_names(gender) "Sex"
  25. set schema_names(father) "Father's Name"
  26. set schema_names(mother) "Mother's Name"
  27. set schema_names(spouse) "Spouse's Name"
  28. set schema_names(address) "Address"
  29. set schema_names(first_visit) "First Visit"
  30. set schema_names(age_years) "Age (y)"
  31. set schema_names(age_months) "Age (m)"
  32.  
  33. proc schema_widget {name} {
  34. switch $name {
  35. "gender" {
  36. set moreargs [list -values [list "" "M" "F"]]
  37. proc gender_spinbox {args} {
  38. return [apply spinbox [concat args moreargs]]
  39. }
  40. return gender_spinbox
  41. }
  42. default {
  43. return entry
  44. }
  45. }
  46. }
  47.  
  48. ## editor.tcl
  49. # source schema.tcl
  50.  
  51. foreach {name label} [array get schema_names] {
  52. label .l_$name -text $label
  53. set widget [schema_widget $name]
  54. $widget .w_$name
  55. grid .l_$name .w_$name
  56. }
  57.  

Comments

Posted by error message at Tue Jul 10 06:48:46 GMT 2007 [text] [code]

Error in startup script: wrong # args: should be "catch command ?varName?" while compiling "catch {uplevel 1 $name $args} res opt" while compiling "set code [catch {uplevel 1 $name $args} res opt]" (compiling body of proc "apply", line 12) invoked from within "apply spinbox [concat args moreargs]" (procedure "gender_spinbox" line 2) invoked from within "$widget .w_$name" ("foreach" body line 4) invoked from within "foreach {name label} [array get schema_names] { label .l_$name -text $label set widget [schema_widget $name] $widget .w_$name grid .l_$name .w_$name }" (file "a.tcl" line 51)