A remote procedure call class

# 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

}