Posted to tcl by colin at Sun Feb 05 07:36:55 GMT 2012view raw
- # oo::socket.tcl - class to listen on a given port, etc
- package provide oo::socket 1.0
- oo::class create oo::socket {
- method listen {params} {
- set -tls {}
- set -port 8080
- dict with params {}
- ::socket -server [list ::apply [list {class opts sock ipaddr rport} {
- if {[dict exists $opts -tls] && [dict get $opts -tls] ne {}} {
- set tlsopts [dict merge {
- -certfile server-public.pem
- -keyfile server-private.pem
- -cadir .
- -cafile ca.pem
- -ssl2 0
- -ssl3 1
- -tls1 1
- -require 0
- -request 1
- } [dict get $opts -tls]]
- if {[dict exists $tlsopts -progress]} {
- set progress "-command [dict get $tlsopts -progress]"
- dict unset tlsopts -progress
- } else {
- set progress {}
- }
- if {[dict exists $tlsopts -password]} {
- set password [list -password [list ::apply [list {} [list return \"$password\"]]]]
- dict unset tlsopts -password
- } else {
- set password {}
- }
- chan configure $sock -blocking 1 -translation {binary binary}
- tls::import $sock -server 1 {*}$tlsopts {*}$progress {*}$password
- tls::handshake $sock
- }
- {*}$class create $sock {*}[expr {[dict exists $opts -args]? [dict get $opts -args] : {}}]
- } [namespace current]] [self] [list -tls ${-tls}]] {*}[expr {([info exists -myaddr] && ${-myaddr} ne "")?"-myaddr ${-myaddr}":""}] ${-port}
- }
- superclass ::oo::class
- constructor {definition args} {
- next $definition
- my listen $args
- return [self]
- }
- }
- if {[info script] eq $argv0} {
- oo::socket create echo {
- method readable {} {
- variable sock
- if {[chan eof $sock]} {
- my destroy
- } else {
- puts $sock [gets $sock]
- }
- }
- destructor {
- puts stderr "[self] destroyed"
- catch {variable sock; close $sock}
- }
- constructor {args} {
- variable sock [namespace tail [self]]
- puts stderr "[self] connected to $sock"
- chan configure $sock -buffering line
- chan event $sock readable [list [self] readable]
- }
- }
- vwait forever
- }