ten/ten.tcl

   1 package require Tcl 8.4
   2
   3 package require snit
   4
   5 namespace eval ::ten:: {
   6   set library [file dirname [info script]]
   7 }
   8
   9 snit::type ten::connector::perl {
  10
  11   method connect {} {
  12     set conn_fh [open {|object-remote-node} r+]
  13     set firstline [gets $conn_fh]
  14     switch $firstline {
  15       Shere {}
  16       default { error "Expected Shere, got $firstline" }
  17     }
  18
  19     set channel [ten::read_channel %AUTO% -fh $conn_fh]
  20
  21     set conn [
  22       ten::connection %AUTO% -send_to_fh $conn_fh -read_channel $channel
  23     ]
  24
  25     return $conn
  26   }
  27 }
  28
  29 snit::type ten::connection {
  30
  31   option -send_to_fh
  32   option -read_channel
  33
  34   constructor {args} {
  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 ] \
  40     ]
  41   }
  42
  43   method Receive {$line} {
  44     puts $line
  45   }
  46
  47   method ChannelClosed {} {
  48     error "Fail"
  49   }
  50
  51   method send {message_type args} {
  52     set future [ten::future %AUTO%]
  53     set call_args [concat $message_type $future $args]
  54   }
  55 }
  56
  57 snit::type ten::future {
  58
  59   variable callbacks ""
  60   variable is_ready 0
  61   variable result ""
  62   variable failure ""
  63
  64   method done {args} {
  65     if [$self is_ready] {
  66       error "Future $self already completed"
  67     }
  68     set result $args
  69     $self MarkReady
  70   }
  71
  72   method fail {args} {
  73     if [$self is_ready] {
  74       error "Future $self already completed"
  75     }
  76     set failure $args
  77     $self MarkReady
  78   }
  79
  80   method on_ready {cb_code} {
  81     if [$self is_ready] {
  82       eval [concat $cb_code $self]
  83     } else {
  84       lappend callbacks [list ready $cb_code]
  85     }
  86   }
  87
  88   method on_done {cb_code} {
  89     if [llength $result] {
  90       eval [concat $cb_code [list $result]]
  91     } else {
  92       lappend callbacks [list done $cb_code]
  93     }
  94   }
  95
  96   method on_fail {cb_code} {
  97     if [llength $failure] {
  98       eval [concat $cb_code [list $failure]]
  99     } else {
 100       lappend callbacks [list fail $cb_code]
 101     }
 102   }
 103
 104   method MarkReady {} {
 105     set is_ready 1
 106     foreach cb $callbacks {
 107       set cb_type [lindex $cb 0]
 108       set cb_code [lindex $cb 1]
 109       switch $cb_type {
 110         ready { eval [concat $cb_code $self] }
 111         done {
 112           if ![$self is_failure] {
 113             eval [concat $cb_code [list $result]]
 114           }
 115         }
 116         failed {
 117           if [$self is_failure] {
 118             eval [concat $cb_code [list $failure]]
 119           }
 120         }
 121       }
 122     }
 123   }
 124
 125   method AssertReady {} {
 126     if {!$is_ready} {
 127       error "Future not ready"
 128     }
 129   }
 130
 131   method is_ready {} { return $is_ready }
 132
 133   method get {} {
 134     $self AssertReady
 135     if [$self is_failure] {
 136       error $failure
 137     }
 138     return $result
 139   }
 140
 141   method is_failure {} {
 142     $self AssertReady
 143     if [llength $failure] {
 144       return 1
 145     }
 146     return 0
 147   }
 148
 149   method failure {} {
 150     $self AssertReady
 151     return $failure
 152   }
 153
 154   method await {} {
 155     vwait "${selfns}::is_ready"
 156   }
 157 }
 158
 159 snit::type ten::read_channel {
 160   option -fh
 161   option -on_close_call
 162   option -on_line_call
 163
 164   constructor {args} {
 165     $self configurelist $args
 166     fconfigure $options(-fh) -blocking 0
 167     fileevent $options(-fh) readable [mymethod ReceiveData]
 168   }
 169
 170   method ReceiveData {} {
 171     set chan $options(-fh)
 172     if [eof $chan] {
 173       if [llength $options(-on_close_call)] {
 174         eval $options(-on_close_call)
 175       }
 176     } else {
 177       if [llength $options(-on_line_call)] {
 178         while {[llength [set line [gets $chan]]] > 0} {
 179           eval [concat $options(-on_line_call) $line]
 180         }
 181       }
 182     }
 183   }
 184 }
 185
 186 package provide ten 0.0.1