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     lappend callbacks [list ready $cb_code]
  82   }
  83
  84   method on_done {cb_code} {
  85     lappend callbacks [list done $cb_code]
  86   }
  87
  88   method on_fail {cb_code} {
  89     lappend callbacks [list fail $cb_code]
  90   }
  91
  92   method MarkReady {} {
  93     set is_ready 1
  94     foreach cb $callbacks {
  95       set cb_type [lindex $cb 0]
  96       set cb_code [lindex $cb 1]
  97       switch $cb_type {
  98         ready { eval [concat $cb_code $self] }
  99         done {
 100           if ![$self is_failure] {
 101             eval [concat $cb_code [list $result]]
 102           }
 103         }
 104         failed {
 105           if [$self is_failure] {
 106             eval [concat $cb_code [list $failure]]
 107           }
 108         }
 109       }
 110     }
 111   }
 112
 113   method AssertReady {} {
 114     if {!$is_ready} {
 115       error "Future not ready"
 116     }
 117   }
 118
 119   method is_ready {} { return $is_ready }
 120
 121   method get {} {
 122     $self AssertReady
 123     if [$self is_failure] {
 124       error $failure
 125     }
 126     return $result
 127   }
 128
 129   method is_failure {} {
 130     $self AssertReady
 131     if [llength $failure] {
 132       return 1
 133     }
 134     return 0
 135   }
 136
 137   method failure {} {
 138     $self AssertReady
 139     return $failure
 140   }
 141
 142   method await {} {
 143     vwait "${selfns}::is_ready"
 144   }
 145 }
 146
 147 snit::type ten::read_channel {
 148   option -fh
 149   option -on_close_call
 150   option -on_line_call
 151
 152   constructor {args} {
 153     $self configurelist $args
 154     fconfigure $options(-fh) -blocking 0
 155     fileevent $options(-fh) readable [mymethod ReceiveData]
 156   }
 157
 158   method ReceiveData {} {
 159     set chan $options(-fh)
 160     if [eof $chan] {
 161       if [llength $options(-on_close_call)] {
 162         eval $options(-on_close_call)
 163       }
 164     } else {
 165       if [llength $options(-on_line_call)] {
 166         while {[llength [set line [gets $chan]]] > 0} {
 167           eval [concat $options(-on_line_call) $line]
 168         }
 169       }
 170     }
 171   }
 172 }
 173
 174 package provide ten 0.0.1