(CMCc 20120207) It is possible to derive from TclOO's oo::class and create meta classes that perform additional actions upon object instance creation, method creation, etc..
oo::socket looks like oo::class, but as a side-effect creates a listener socket (specified by additional arguments to the oo::socket create or oo::socket new commands) that constructs a new instance of the class to service each new connection. The object created will be named for the socket. The example class, ::echo (given below) merely echoes what it receives.
# 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 $opts -progress]} {
set progress "-command [dict get $opts -progress]"
} else {
set progress {}
}
if {[dict exists $opts -password]} {
set password [list -password [list ::apply [list {} [list return "\"[dict get $opts -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
}