Posted to tcl by colin at Mon Feb 06 11:39:15 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 $opts -progress]} {
  25. set progress "-command [dict get $opts -progress]"
  26. } else {
  27. set progress {}
  28. }
  29. if {[dict exists $opts -password]} {
  30. set password [list -password [list ::apply [list {} [list return \"[dict get $opts -password]\"]]]]
  31. } else {
  32. set password {}
  33. }
  34.  
  35. chan configure $sock -blocking 1 -translation {binary binary}
  36. tls::import $sock -server 1 {*}$tlsopts {*}$progress {*}$password
  37. tls::handshake $sock
  38. }
  39.  
  40. {*}$class create $sock {*}[expr {[dict exists $opts -args]? [dict get $opts -args] : {}}]
  41. } [namespace current]] [self] [list -tls ${-tls}]] {*}[expr {([info exists -myaddr] && ${-myaddr} ne "")?"-myaddr ${-myaddr}":""}] ${-port}
  42. }
  43.  
  44. superclass ::oo::class
  45. constructor {definition args} {
  46. next $definition
  47. my listen $args
  48. return [self]
  49. }
  50. }
  51.  
  52. if {[info script] eq $argv0} {
  53. oo::socket create echo {
  54. method readable {} {
  55. variable sock
  56. if {[chan eof $sock]} {
  57. my destroy
  58. } else {
  59. puts $sock [gets $sock]
  60. }
  61. }
  62.  
  63. destructor {
  64. puts stderr "[self] destroyed"
  65. catch {variable sock; close $sock}
  66. }
  67.  
  68. constructor {args} {
  69. variable sock [namespace tail [self]]
  70. puts stderr "[self] connected to $sock"
  71. chan configure $sock -buffering line
  72. chan event $sock readable [list [self] readable]
  73. }
  74. }
  75. vwait forever
  76. }