Posted to tcl by colin at Tue Jan 31 16:03:45 GMT 2012view raw
- # rpclass.tcl - remote procedure call classes
- ::oo::class create ::oo::rpc::server {
- method getpacket {sock} {
- if {[binary scan [read $sock 4] I len] != 1} {
- error "$sock closed"
- }
- return [read $sock $len]
- }
- method putpacket {sock data} {
- set content [binary format I [string length $data]]$data
- puts -nonewline $sock $content
- flush $sock
- }
- method connect {sock args} {
- chan configure $sock -translation {binary binary} -encoding binary -buffering none
- set constructor [my getpacket $sock]
- set obj [uplevel #0 [self] new {*}$constructor]
- my putpacket $sock $obj
- oo::objdefine $obj {
- method __dispatch__ {sock} {
- set result {}
- while {1} {
- catch {my {*}[[info object class [self]] getpacket $sock]} e eo
- if {[catch {
- [info object class [self]] putpacket $sock [list -options $eo $e]
- }]} {
- catch {close $sock}
- catch {[self] destroy}
- break
- }
- }
- }
- export __dispatch__
- }
- trace add command $obj delete [list catch [list close $sock]]
- chan event $sock readable [list $obj __dispatch__ $sock]
- }
- export connect
- superclass ::oo::class
- constructor {args} {
- set name [self]
- lassign $args port host body
- if {$body eq ""} {
- set body $host
- set opts {}
- } else {
- set opts [list -myaddress $host]
- }
- set listener [socket -server [list [self] connect] {*}$opts $port]
- next $body
- return [self]
- }
- }
- ::oo::class create ::oo::rpc::client {
- method cleanup {obj sock} {
- catch {$obj destroy}
- set cmd destroy
- catch {
- puts -nonewline $sock [binary format I [string length $cmd]]$cmd
- flush $sock
- }
- catch {close $sock}
- }
- method intervene {obj cargs} {
- variable c2hp
- set sock [socket {*}[dict get $c2hp [self]]]
- chan configure $sock -translation {binary binary} -encoding binary -buffering none
- trace add command $obj delete [list [self] cleanup $obj $sock]
- set cmd [binary format I [string length $cargs]]$cargs
- puts -nonewline $sock $cmd; flush $sock
- if {[binary scan [::read $sock 4] I len] != 1} {
- error "$sock closed on [self]"
- }
- set robj [::read $sock $len]
- set [info object namespace $obj]::__sock $sock
- return $obj
- }
- method new {args} {
- my intervene [next {*}$args] $args
- }
- method create {args} {
- my intervene [next {*}$args] [lrange $args 1 end]
- }
- superclass ::oo::class
- constructor {host port args} {
- set class [self]
- variable c2hp; dict set c2hp $class [list $host $port]
- next {*}$args
- oo::define $class method unknown {args} {
- variable __sock
- puts -nonewline $__sock [binary format I [string length $args]]$args
- if {[binary scan [::read $__sock 4] I len] != 1} {
- error "$__sock closed on [self]"
- }
- return {*}[::read $__sock $len]
- }
- }
- }
- if {[info script] eq $argv0} {
- if {[lindex $argv 0]} {
- oo::rpc::server create Fred 8080 {
- method Var {var} {
- variable $var
- return [set $var]
- }
- method error {} {
- error "This is an intentional ERROR"
- }
- constructor {args} {
- variable {*}$args
- }
- }
- } else {
- oo::rpc::client create Fred@8080 localhost 8080 {
- method local {} {
- puts stderr "This is a local method"
- }
- }
- set fred [Fred@8080 create fred a 1 b 2 c 3]
- $fred local
- puts [$fred Var a]
- $fred error
- }
- vwait forever
- }