1 package require Tcl 8.4
5 namespace eval ::ten:: {
6 set library [file dirname [info script]]
9 snit::type ten::connector::perl {
12 set conn_fh [open {|object-remote-node} r+]
13 set firstline [gets $conn_fh]
16 default { error "Expected Shere, got $firstline" }
19 set channel [ten::read_channel %AUTO% -fh $conn_fh]
22 ten::connection %AUTO% -send_to_fh $conn_fh -read_channel $channel
29 snit::type ten::connection {
35 $self configurelist $args
36 fconfigure $options(-send_to_fh) -buffering none
37 $options(-read_channel) configurelist [list \
38 -on_line_call [ mymethod Receive ] \
39 -on_close_call [ mymethod ChannelClosed ] \
43 method Receive {$line} {
47 method ChannelClosed {} {
51 method send {message_type args} {
52 set future [ten::future %AUTO%]
53 set call_args [concat $message_type $future $args]
57 snit::type ten::future {
66 error "Future $self already completed"
74 error "Future $self already completed"
80 method on_ready {cb_code} {
82 eval [concat $cb_code $self]
84 lappend callbacks [list ready $cb_code]
88 method on_done {cb_code} {
89 if [llength $result] {
90 eval [concat $cb_code [list $result]]
92 lappend callbacks [list done $cb_code]
96 method on_fail {cb_code} {
97 if [llength $failure] {
98 eval [concat $cb_code [list $failure]]
100 lappend callbacks [list fail $cb_code]
104 method MarkReady {} {
106 foreach cb $callbacks {
107 set cb_type [lindex $cb 0]
108 set cb_code [lindex $cb 1]
110 ready { eval [concat $cb_code $self] }
112 if ![$self is_failure] {
113 eval [concat $cb_code [list $result]]
117 if [$self is_failure] {
118 eval [concat $cb_code [list $failure]]
125 method AssertReady {} {
127 error "Future not ready"
131 method is_ready {} { return $is_ready }
135 if [$self is_failure] {
141 method is_failure {} {
143 if [llength $failure] {
155 vwait "${selfns}::is_ready"
159 snit::type ten::read_channel {
161 option -on_close_call
165 $self configurelist $args
166 fconfigure $options(-fh) -blocking 0
167 fileevent $options(-fh) readable [mymethod ReceiveData]
170 method ReceiveData {} {
171 set chan $options(-fh)
173 if [llength $options(-on_close_call)] {
174 eval $options(-on_close_call)
177 if [llength $options(-on_line_call)] {
178 while {[llength [set line [gets $chan]]] > 0} {
179 eval [concat $options(-on_line_call) $line]
186 package provide ten 0.0.1