ten/ten.tcl

   1 package require Tcl 8.5
   2
   3 package require snit
   4 package require json::write
   5 package require json
   6
   7 namespace eval ::ten:: {
   8   set library [file dirname [info script]]
   9
  10   proc nofuture {args} {}
  11 }
  12
  13 snit::type ten::connector::perl {
  14
  15   method connect {} {
  16     set conn_fh [open {|object-remote-node} r+]
  17     set firstline [gets $conn_fh]
  18     switch $firstline {
  19       Shere {}
  20       default { error "Expected Shere, got $firstline" }
  21     }
  22
  23     set channel [ten::read_channel %AUTO% -fh $conn_fh]
  24
  25     set conn [
  26       ten::connection %AUTO% -send_to_fh $conn_fh -read_channel $channel
  27     ]
  28
  29     return $conn
  30   }
  31 }
  32
  33 snit::type ten::connection {
  34
  35   option -send_to_fh
  36   option -read_channel
  37
  38   constructor {args} {
  39     $self configurelist $args
  40     fconfigure $options(-send_to_fh) -buffering none
  41     $options(-read_channel) configurelist [list \
  42       -on_line_call [ mymethod Receive ] \
  43       -on_close_call [ mymethod ChannelClosed ] \
  44     ]
  45   }
  46
  47   method Receive {line} {
  48     set tcl_line [ json::json2dict $line ]
  49     set type [ lindex $tcl_line 0 ]
  50     set rest [ lrange $tcl_line 1 end ]
  51     $self "receive_$type" {*}$rest
  52   }
  53
  54   method receive_call_free {future_id id args} {
  55     $self receive_call $future_id $id "" {*}$args
  56     $self receive_free $id
  57   }
  58
  59   method receive_call {future_id id args} {
  60     if {$future_id == "NULL"} {
  61       set future ten::nofuture
  62     } else {
  63       set future $future_id
  64     }
  65     $self Invoke $future $id {*}$args
  66   }
  67
  68   method receive_free {id} {
  69     $id free
  70   }
  71
  72   method Invoke {future local ctx method args} {
  73     set result [$local $method {*}$args]
  74     $future done $result
  75   }
  76
  77   method ChannelClosed {} {
  78     error "Fail"
  79   }
  80
  81   method send {message_type args} {
  82     set future [ten::future %AUTO%]
  83     set call_args [list \
  84       [ json::write string $message_type ] \
  85       [ json::write string $future ] \
  86       {*}$args
  87     ]
  88     $self Send $call_args
  89     return $future
  90   }
  91
  92   method Send {to_send} {
  93     set send_this [ json::write array {*}$to_send ]
  94     puts $options(-send_to_fh) $send_this
  95   }
  96 }
  97
  98 snit::type ten::future {
  99
 100   variable callbacks ""
 101   variable is_ready 0
 102   variable result ""
 103   variable failure ""
 104   variable retain_count 1
 105
 106   method done {args} {
 107     if [$self is_ready] {
 108       error "Future $self already completed"
 109     }
 110     set result $args
 111     $self MarkReady
 112   }
 113
 114   method fail {args} {
 115     if [$self is_ready] {
 116       error "Future $self already completed"
 117     }
 118     set failure $args
 119     $self MarkReady
 120   }
 121
 122   method on_ready {cb_code} {
 123     if [$self is_ready] {
 124       eval [concat $cb_code $self]
 125     } else {
 126       lappend callbacks [list ready $cb_code]
 127     }
 128   }
 129
 130   method on_done {cb_code} {
 131     if [llength $result] {
 132       eval [concat $cb_code [list $result]]
 133     } else {
 134       lappend callbacks [list done $cb_code]
 135     }
 136   }
 137
 138   method on_fail {cb_code} {
 139     if [llength $failure] {
 140       eval [concat $cb_code [list $failure]]
 141     } else {
 142       lappend callbacks [list fail $cb_code]
 143     }
 144   }
 145
 146   method MarkReady {} {
 147     set is_ready 1
 148     foreach cb $callbacks {
 149       set cb_type [lindex $cb 0]
 150       set cb_code [lindex $cb 1]
 151       switch $cb_type {
 152         ready { eval [concat $cb_code $self] }
 153         done {
 154           if ![$self is_failure] {
 155             eval [concat $cb_code [list $result]]
 156           }
 157         }
 158         failed {
 159           if [$self is_failure] {
 160             eval [concat $cb_code [list $failure]]
 161           }
 162         }
 163       }
 164     }
 165   }
 166
 167   method AssertReady {} {
 168     if {!$is_ready} {
 169       error "Future not ready"
 170     }
 171   }
 172
 173   method is_ready {} { return $is_ready }
 174
 175   method get {} {
 176     $self AssertReady
 177     if [$self is_failure] {
 178       error $failure
 179     }
 180     return $result
 181   }
 182
 183   method is_failure {} {
 184     $self AssertReady
 185     if [llength $failure] {
 186       return 1
 187     }
 188     return 0
 189   }
 190
 191   method failure {} {
 192     $self AssertReady
 193     return $failure
 194   }
 195
 196   method await_ready {} {
 197     vwait "${selfns}::is_ready"
 198   }
 199
 200   method retain {} {
 201     incr retain_count
 202   }
 203
 204   method free {} {
 205     set retain_count [ expr $retain_count - 1 ]
 206     if {$retain_count == 0} {
 207       $self destroy
 208     }
 209   }
 210 }
 211
 212 snit::type ten::read_channel {
 213   option -fh
 214   option -on_close_call
 215   option -on_line_call
 216
 217   constructor {args} {
 218     $self configurelist $args
 219     fconfigure $options(-fh) -blocking 0
 220     fileevent $options(-fh) readable [mymethod ReceiveData]
 221   }
 222
 223   method ReceiveData {} {
 224     set chan $options(-fh)
 225     if [eof $chan] {
 226       if [llength $options(-on_close_call)] {
 227         eval $options(-on_close_call)
 228       }
 229     } else {
 230       if [llength $options(-on_line_call)] {
 231         while {[llength [set line [gets $chan]]] > 0} {
 232           eval [concat $options(-on_line_call) [ list $line ]]
 233         }
 234       }
 235     }
 236   }
 237 }
 238
 239 package provide ten 0.0.1