Posted to tcl by aspect at Thu Sep 11 04:47:17 GMT 2014view raw

  1. #
  2. # for providing commands:
  3. # eg: [evalwith $obj [info object methods -all $obj] $script
  4. # will make all methods of obj available as top-level commands
  5. proc evalwith {eval commands script} {
  6. set eval [uplevel 1 namespace which -command [list $eval]]
  7. set ns [newns]
  8. set path [uplevel 1 {linsert [namespace path] 0 [namespace current]}]
  9. namespace eval $ns [list namespace path $path]
  10. foreach cmd $commands {
  11. interp alias {} ${ns}::$cmd {} $eval $cmd
  12. }
  13. interp alias {} ${ns}::self {} ::uplevel 1 self
  14. try {
  15. uplevel 1 [list namespace eval $ns $script]
  16. } finally {
  17. namespace delete $ns
  18. }
  19. }
  20.  
  21. # from the wiki - extend an ensemble with new commands
  22. proc extend {ens script} {
  23. namespace eval $ens [concat {
  24. proc _unknown {ens cmd args} {
  25. if {$cmd in [namespace eval ::${ens} {::info commands}]} {
  26. set map [namespace ensemble configure $ens -map]
  27. dict set map $cmd ::${ens}::$cmd
  28. namespace ensemble configure $ens -map $map
  29. }
  30. return "" ;# back to namespace ensemble dispatch
  31. }
  32. } \; $script]
  33. namespace ensemble configure $ens -unknown ${ens}::_unknown
  34.  
  35. }
  36.  
  37. extend dict {
  38. # dict lambda can create a lambdaexpr with the dict keys as params, defaulted to their values
  39. proc lambda {dict script} {
  40. tailcall ::lambda [lmap {k v} $dict {list $k $v}] $script
  41. }
  42. }
  43.  
  44.  
  45. extend array {
  46.  
  47. # like [dict with], but for an array
  48. # and without leaking. So it needs a namespace argument
  49. proc with {_array script {ns ""}} {
  50. upvar 1 $_array a
  51. set prelude [lmap name [array names a] {
  52. list upvar 1 a($name) $name
  53. }]
  54. set prelude [join $prelude \n]
  55. set script $prelude\n$script
  56. if {$ns eq ""} {set ns [list $ns]}
  57. apply [list {} $script {*}$ns]
  58. }
  59. }
  60.