Posted to tcl by mjanssen at Tue Apr 20 15:15:58 GMT 2021view raw

  1. package require http
  2. namespace eval with {
  3. oo::class create FileCtxt {
  4. variable res
  5. method enter args {
  6. variable res [open {*}$args]
  7. return $res
  8. }
  9. method exit {} {
  10. variable res
  11. return [close $res]
  12. }
  13. }
  14. oo::class create HttpCtxt {
  15. variable res
  16. method enter args {
  17. variable res [http::geturl {*}$args]
  18. return $res
  19. }
  20. method exit {} {
  21. variable res
  22. return [http::cleanup $res]
  23. }
  24. }
  25.  
  26. proc register {command contextCreator} {
  27. proc $command {varName args} [string map [list @@ $contextCreator] {
  28. if {[llength $args] < 1} {
  29. error "no block provided"
  30. }
  31. set block [lindex $args end]
  32. set ctxt [{*}@@] ;
  33. upvar 1 $varName res
  34. set res [$ctxt enter {*}[lrange $args 0 end-1]] ;
  35. set result [uplevel 1 $block] ;
  36. $ctxt exit
  37. return $result
  38. }]
  39.  
  40. # Eval $block with $name s
  41. proc alias {alias target block} {
  42. set old [interp alias {} $alias]
  43. interp alias {} $alias {} $target
  44. set result [uplevel 1 $block]
  45. interp alias {} $alias {} $old
  46. return $result
  47. }
  48. }
  49.  
  50. register ::with::file [list ::with::FileCtxt new]
  51. register ::with::http [list ::with::HttpCtxt new]
  52. }