Posted to tcl by aspect at Fri Jul 04 23:08:55 GMT 2014view raw

  1. # a simple transchan to log everything that's written
  2. # supports [read] as well, so it can be used on bidirectional chans
  3. namespace eval logchan {
  4. proc initialize args {
  5. info procs
  6. }
  7. proc finalize args {}
  8. proc clear args {}
  9. proc write {x h data} {
  10. uplevel #0 $x [list $data]
  11. return $data
  12. }
  13. proc read {x h data} {
  14. return $data
  15. }
  16.  
  17. namespace export *
  18. namespace ensemble create -parameters x
  19. }
  20.  
  21. # test using logchan with http and tls
  22. proc test {} {
  23.  
  24. package require http 2.7
  25. #source http.tcl
  26. package require tls
  27. proc ::http::Log {args} {puts "HTTP: $args"}
  28.  
  29. proc tlssock args {
  30. set r [::tls::socket {*}$args]
  31. set cmdPrefix [string map [list :R $r] {apply {{data} {
  32. puts "SENDING :R: $data"
  33. }}}]
  34. chan push $r [list logchan $cmdPrefix]
  35. return $r
  36. }
  37.  
  38. proc ssock args {
  39. set r [socket {*}$args]
  40. set cmdPrefix [string map [list :R $r] {apply {{data} {
  41. puts "SENDING :R: $data"
  42. }}}]
  43. chan push $r [list logchan $cmdPrefix]
  44. return $r
  45. }
  46.  
  47. http::register http 80 ssock
  48. http::register https 443 tlssock
  49.  
  50. # this one is fine:
  51. set tok [::http::geturl http://google.com]
  52. upvar 1 $tok state
  53. puts "http: $state(http)"
  54. ::http::cleanup $tok
  55.  
  56. # this gets an error calling [flush] in http::Connected:
  57. set tok [::http::geturl https://google.com]
  58. upvar 1 $tok state
  59. puts "https: $state(http)"
  60. ::http::cleanup $tok
  61. }
  62. test
  63.