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     $self Send [concat
  54       [list list "str $message_type" "str $future"] $args
  55     ]
  56   }
  57
  58   method Send {to_send} {
  59     puts $options(-send_to_fh) [$self Serialize $to_send]
  60   }
  61
  62   method Serialize {
  63   }
  64 }
  65
  66 snit::type ten::future {
  67
  68   variable callbacks ""
  69   variable is_ready 0
  70   variable result ""
  71   variable failure ""
  72
  73   method done {args} {
  74     if [$self is_ready] {
  75       error "Future $self already completed"
  76     }
  77     set result $args
  78     $self MarkReady
  79   }
  80
  81   method fail {args} {
  82     if [$self is_ready] {
  83       error "Future $self already completed"
  84     }
  85     set failure $args
  86     $self MarkReady
  87   }
  88
  89   method on_ready {cb_code} {
  90     if [$self is_ready] {
  91       eval [concat $cb_code $self]
  92     } else {
  93       lappend callbacks [list ready $cb_code]
  94     }
  95   }
  96
  97   method on_done {cb_code} {
  98     if [llength $result] {
  99       eval [concat $cb_code [list $result]]
 100     } else {
 101       lappend callbacks [list done $cb_code]
 102     }
 103   }
 104
 105   method on_fail {cb_code} {
 106     if [llength $failure] {
 107       eval [concat $cb_code [list $failure]]
 108     } else {
 109       lappend callbacks [list fail $cb_code]
 110     }
 111   }
 112
 113   method MarkReady {} {
 114     set is_ready 1
 115     foreach cb $callbacks {
 116       set cb_type [lindex $cb 0]
 117       set cb_code [lindex $cb 1]
 118       switch $cb_type {
 119         ready { eval [concat $cb_code $self] }
 120         done {
 121           if ![$self is_failure] {
 122             eval [concat $cb_code [list $result]]
 123           }
 124         }
 125         failed {
 126           if [$self is_failure] {
 127             eval [concat $cb_code [list $failure]]
 128           }
 129         }
 130       }
 131     }
 132   }
 133
 134   method AssertReady {} {
 135     if {!$is_ready} {
 136       error "Future not ready"
 137     }
 138   }
 139
 140   method is_ready {} { return $is_ready }
 141
 142   method get {} {
 143     $self AssertReady
 144     if [$self is_failure] {
 145       error $failure
 146     }
 147     return $result
 148   }
 149
 150   method is_failure {} {
 151     $self AssertReady
 152     if [llength $failure] {
 153       return 1
 154     }
 155     return 0
 156   }
 157
 158   method failure {} {
 159     $self AssertReady
 160     return $failure
 161   }
 162
 163   method await {} {
 164     vwait "${selfns}::is_ready"
 165   }
 166 }
 167
 168 snit::type ten::read_channel {
 169   option -fh
 170   option -on_close_call
 171   option -on_line_call
 172
 173   constructor {args} {
 174     $self configurelist $args
 175     fconfigure $options(-fh) -blocking 0
 176     fileevent $options(-fh) readable [mymethod ReceiveData]
 177   }
 178
 179   method ReceiveData {} {
 180     set chan $options(-fh)
 181     if [eof $chan] {
 182       if [llength $options(-on_close_call)] {
 183         eval $options(-on_close_call)
 184       }
 185     } else {
 186       if [llength $options(-on_line_call)] {
 187         while {[llength [set line [gets $chan]]] > 0} {
 188           eval [concat $options(-on_line_call) $line]
 189         }
 190       }
 191     }
 192   }
 193 }
 194
 195 package provide ten 0.0.1