Posted to tcl by colin at Sun Feb 05 07:36:55 GMT 2012view raw

  1. # oo::socket.tcl - class to listen on a given port, etc
  2. package provide oo::socket 1.0
  3.  
  4. oo::class create oo::socket {
  5. method listen {params} {
  6. set -tls {}
  7. set -port 8080
  8. dict with params {}
  9.  
  10. ::socket -server [list ::apply [list {class opts sock ipaddr rport} {
  11. if {[dict exists $opts -tls] && [dict get $opts -tls] ne {}} {
  12. set tlsopts [dict merge {
  13. -certfile server-public.pem
  14. -keyfile server-private.pem
  15. -cadir .
  16. -cafile ca.pem
  17. -ssl2 0
  18. -ssl3 1
  19. -tls1 1
  20. -require 0
  21. -request 1
  22. } [dict get $opts -tls]]
  23.  
  24. if {[dict exists $tlsopts -progress]} {
  25. set progress "-command [dict get $tlsopts -progress]"
  26. dict unset tlsopts -progress
  27. } else {
  28. set progress {}
  29. }
  30. if {[dict exists $tlsopts -password]} {
  31. set password [list -password [list ::apply [list {} [list return \"$password\"]]]]
  32. dict unset tlsopts -password
  33. } else {
  34. set password {}
  35. }
  36.  
  37. chan configure $sock -blocking 1 -translation {binary binary}
  38. tls::import $sock -server 1 {*}$tlsopts {*}$progress {*}$password
  39. tls::handshake $sock
  40. }
  41. {*}$class create $sock {*}[expr {[dict exists $opts -args]? [dict get $opts -args] : {}}]
  42. } [namespace current]] [self] [list -tls ${-tls}]] {*}[expr {([info exists -myaddr] && ${-myaddr} ne "")?"-myaddr ${-myaddr}":""}] ${-port}
  43. }
  44.  
  45. superclass ::oo::class
  46. constructor {definition args} {
  47. next $definition
  48. my listen $args
  49. return [self]
  50. }
  51. }
  52.  
  53. if {[info script] eq $argv0} {
  54. oo::socket create echo {
  55. method readable {} {
  56. variable sock
  57. if {[chan eof $sock]} {
  58. my destroy
  59. } else {
  60. puts $sock [gets $sock]
  61. }
  62. }
  63.  
  64. destructor {
  65. puts stderr "[self] destroyed"
  66. catch {variable sock; close $sock}
  67. }
  68.  
  69. constructor {args} {
  70. variable sock [namespace tail [self]]
  71. puts stderr "[self] connected to $sock"
  72. chan configure $sock -buffering line
  73. chan event $sock readable [list [self] readable]
  74. }
  75. }
  76. vwait forever
  77. }