Posted to tcl by colin at Tue Jan 31 16:03:45 GMT 2012view raw

  1. # rpclass.tcl - remote procedure call classes
  2.  
  3. ::oo::class create ::oo::rpc::server {
  4. method getpacket {sock} {
  5. if {[binary scan [read $sock 4] I len] != 1} {
  6. error "$sock closed"
  7. }
  8. return [read $sock $len]
  9. }
  10.  
  11. method putpacket {sock data} {
  12. set content [binary format I [string length $data]]$data
  13. puts -nonewline $sock $content
  14. flush $sock
  15. }
  16.  
  17. method connect {sock args} {
  18. chan configure $sock -translation {binary binary} -encoding binary -buffering none
  19. set constructor [my getpacket $sock]
  20. set obj [uplevel #0 [self] new {*}$constructor]
  21. my putpacket $sock $obj
  22.  
  23. oo::objdefine $obj {
  24. method __dispatch__ {sock} {
  25. set result {}
  26. while {1} {
  27. catch {my {*}[[info object class [self]] getpacket $sock]} e eo
  28. if {[catch {
  29. [info object class [self]] putpacket $sock [list -options $eo $e]
  30. }]} {
  31. catch {close $sock}
  32. catch {[self] destroy}
  33. break
  34. }
  35. }
  36. }
  37. export __dispatch__
  38. }
  39.  
  40. trace add command $obj delete [list catch [list close $sock]]
  41. chan event $sock readable [list $obj __dispatch__ $sock]
  42. }
  43. export connect
  44.  
  45. superclass ::oo::class
  46. constructor {args} {
  47. set name [self]
  48.  
  49. lassign $args port host body
  50. if {$body eq ""} {
  51. set body $host
  52. set opts {}
  53. } else {
  54. set opts [list -myaddress $host]
  55. }
  56.  
  57. set listener [socket -server [list [self] connect] {*}$opts $port]
  58.  
  59. next $body
  60.  
  61. return [self]
  62. }
  63. }
  64.  
  65. ::oo::class create ::oo::rpc::client {
  66. method cleanup {obj sock} {
  67. catch {$obj destroy}
  68. set cmd destroy
  69. catch {
  70. puts -nonewline $sock [binary format I [string length $cmd]]$cmd
  71. flush $sock
  72. }
  73. catch {close $sock}
  74. }
  75. method intervene {obj cargs} {
  76. variable c2hp
  77. set sock [socket {*}[dict get $c2hp [self]]]
  78. chan configure $sock -translation {binary binary} -encoding binary -buffering none
  79. trace add command $obj delete [list [self] cleanup $obj $sock]
  80. set cmd [binary format I [string length $cargs]]$cargs
  81. puts -nonewline $sock $cmd; flush $sock
  82. if {[binary scan [::read $sock 4] I len] != 1} {
  83. error "$sock closed on [self]"
  84. }
  85. set robj [::read $sock $len]
  86.  
  87. set [info object namespace $obj]::__sock $sock
  88. return $obj
  89. }
  90.  
  91. method new {args} {
  92. my intervene [next {*}$args] $args
  93. }
  94.  
  95. method create {args} {
  96. my intervene [next {*}$args] [lrange $args 1 end]
  97. }
  98.  
  99. superclass ::oo::class
  100. constructor {host port args} {
  101. set class [self]
  102. variable c2hp; dict set c2hp $class [list $host $port]
  103.  
  104. next {*}$args
  105. oo::define $class method unknown {args} {
  106. variable __sock
  107. puts -nonewline $__sock [binary format I [string length $args]]$args
  108. if {[binary scan [::read $__sock 4] I len] != 1} {
  109. error "$__sock closed on [self]"
  110. }
  111. return {*}[::read $__sock $len]
  112. }
  113. }
  114. }
  115.  
  116. if {[info script] eq $argv0} {
  117. if {[lindex $argv 0]} {
  118. oo::rpc::server create Fred 8080 {
  119. method Var {var} {
  120. variable $var
  121. return [set $var]
  122. }
  123. method error {} {
  124. error "This is an intentional ERROR"
  125. }
  126.  
  127. constructor {args} {
  128. variable {*}$args
  129. }
  130. }
  131. } else {
  132. oo::rpc::client create Fred@8080 localhost 8080 {
  133. method local {} {
  134. puts stderr "This is a local method"
  135. }
  136. }
  137.  
  138. set fred [Fred@8080 create fred a 1 b 2 c 3]
  139. $fred local
  140. puts [$fred Var a]
  141. $fred error
  142. }
  143.  
  144. vwait forever
  145.  
  146. }