Posted to tcl by colin at Sun Mar 18 01:46:37 GMT 2012view raw
- # coclass.tcl - classes which are also coros
- package provide oo::coclass 1.0
- if {[info commands ::yieldm] eq ""} {
- namespace eval tcl::unsupported namespace export yieldm
- namespace import tcl::unsupported::yieldm
- }
- if {[info commands ::oo::define::classmethod] eq ""} {
- proc ::oo::define::classmethod {name {args {}} {body {}}} {
- set class [lindex [info level -1] 1]
- set classmy [info object namespace $class]::my
- if {[llength [info level 0]] == 4} {
- uplevel 1 [list self method $name $args $body]
- }
- uplevel 1 [list forward $name $classmy $name]
- }
- }
- oo::class create oo::coclass {
- # objgone - the object has died - kill the coro too
- classmethod objgone {obj coro} {
- trace delete command $coro delete [list ::oo::coclass corogone $obj $coro]
- rename $coro {}
- }
- # corogone - the coro has gone - restart it if the object is still there.
- classmethod corogone {obj coro} {
- if {[info commands $obj] ne ""} {
- # (re)create a coro attachment to $obj
- coroutine $coro $obj __dispatch__ ;# create our coro with the object's name
- trace add command $coro delete [list ::oo::coclass corogone $obj $coro]
- } else {
- # both the object and the coro have gone.
- }
- }
- # intervene - add a __dispatch__ method to the object
- # __dispatch__ shims between the fake object (coro) and the actual object.
- method intervene {obj} {
- rename $obj ${obj}_ ;# move the object out of the way
- trace add command ${obj}_ delete [list ::oo::coclass::objgone ${obj}_ $obj]
- my corogone ${obj}_ $obj
- return $obj
- }
- # new - create a new instance of this class,
- # shimmed so it's actually being invoked as a coro
- method new {args} {
- tailcall my intervene [next {*}$args]
- }
- # new - create a new instance of this class,
- # shimmed so it's actually being invoked as a coro
- method create {name args} {
- tailcall my intervene [next $name {*}$args]
- }
- superclass ::oo::class
- constructor {args} {
- next {*}$args
- # add a __dispatch__ method to the class to shim between coro interface and object instance
- if {"__dispatch__" ni [info class methods [self] -all]} {
- oo::define [self] {
- method __dispatch__ {} {
- set self [info coroutine] ;# this is the coroutine
- set obj [self] ;# the original obj being forwarded to
- set result {} ;# method invocation result
- catch {
- while {1} {
- # invoke whatever's passed in and return the result
- set result [my {*}[::yieldm $result]]
- }
- } e eo
- # The method invocation errored
- # this will kill the coro if we return it, but it must be returned to caller
- # So we must make another identically named coro and then return the error
- # from this inevitably doomed coro.
- rename $self ${self}_dead_
- if {[catch {::oo::coclass corogone $obj $self} e1 eo1]} {
- # we failed to make the replacement coro - here's why
- puts stderr "corogone fail: $e1 ($eo1)"
- }
- return -options $eo $e ;# return the error result to the caller
- # this instance of the coro goes away now but will be reinstated via [trace]
- }
- export __dispatch__
- }
- }
- return [self]
- }
- }
- if {[info script] eq $argv0} {
- oo::coclass create Fred {
- method Var {var} {
- variable $var
- return [set $var]
- }
- method error {} {
- error "ERROR"
- }
- constructor {args} {
- variable {*}$args
- }
- }
- set fred [Fred new a 1 b 2 c 3]
- puts [$fred Var a]
- if {[catch {$fred error}]} {
- puts stderr "CAUGHT"
- }
- puts [$fred Var b]
- $fred destroy
- }