From: Matt S Trout <mst@shadowcat.co.uk>
Date: Sun, 5 Aug 2012 17:54:22 +0000 (+0000)
Subject: basic future tests
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=b0dd297177ca9b7daaa3028ea4da1524ed3316ff;p=scpubgit%2FTenDotTcl.git

basic future tests
---

diff --git a/t/future.t b/t/future.t
index ef9ae98..28cfd7a 100644
--- a/t/future.t
+++ b/t/future.t
@@ -9,12 +9,22 @@ ok {![f1 is_ready]} "Future not yet ready"
 set ready_args ""
 set done_args ""
 
-f1 on_ready {set "[namespace current]::ready_args"}
+f1 on_ready [list set "[namespace current]::ready_args"]
 
-f1 on_done {set "[namespace current]::done_args"}
+f1 on_done [list set "[namespace current]::done_args"]
 
 f1 done foo bar
 
 ok {[f1 is_ready]} "Future ready"
 
+is $ready_args {::f1} "Future passed to ready"
+
+cmp_ok == [llength $done_args] 2 "Both args passed to done"
+
+is [lindex $done_args 0] foo "Right first arg"
+
+is [lindex $done_args 1] bar "Right second arg"
+
+is [f1 get] "foo bar" "get return ok"
+
 done_testing
diff --git a/ten/ten.tcl b/ten/ten.tcl
index 184b161..15be14d 100644
--- a/ten/ten.tcl
+++ b/ten/ten.tcl
@@ -10,7 +10,7 @@ snit::type ten::connector::perl {
 
   method connect {} {
     set conn_fh [open {|object-remote-node} r+]
-    set firstline [gets conn_fh]
+    set firstline [gets $conn_fh]
     switch $firstline {
       Shere {}
       default { error "Expected Shere, got $firstline" }
@@ -24,7 +24,125 @@ snit::type ten::connector::perl {
 
     return $conn
   }
-} 
+}
+
+snit::type ten::connection {
+
+  option -send_to_fh
+  option -read_channel
+
+  constructor {args} {
+    $self configurelist $args
+    fconfigure $options(-send_to_fh) -buffering none
+    $options(-read_channel) configurelist [list \
+      -on_line_call [ mymethod Receive ] \
+      -on_close_call [ mymethod ChannelClosed ] \
+    ]
+  }
+
+  method Receive {$line} {
+    puts $line
+  }
+
+  method ChannelClosed {} {
+    error "Fail"
+  }
+
+  method send {message_type args} {
+    set future [ten::future %AUTO%]
+    set call_args [concat $message_type $future $args] 
+  }
+}
+
+snit::type ten::future {
+
+  variable callbacks
+  variable is_ready 0
+  variable result ""
+  variable failure ""
+  
+  method done {args} {
+    if [$self is_ready] {
+      error "Future $self already completed"
+    }
+    set result $args
+    $self MarkReady
+  }
+
+  method fail {args} {
+    if [$self is_ready] {
+      error "Future $self already completed"
+    }
+    set failure $args
+    $self MarkReady
+  }
+
+  method on_ready {cb_code} {
+    lappend callbacks [list ready $cb_code]
+  }
+
+  method on_done {cb_code} {
+    lappend callbacks [list done $cb_code]
+  }
+
+  method on_fail {cb_code} {
+    lappend callbacks [list fail $cb_code]
+  }
+
+  method MarkReady {} {
+    set is_ready 1
+    foreach cb $callbacks {
+      set cb_type [lindex $cb 0]
+      set cb_code [lindex $cb 1]
+      switch $cb_type {
+        ready { eval [concat $cb_code $self] }
+        done {
+          if ![$self is_failure] {
+            eval [concat $cb_code [list $result]]
+          }
+        }
+        failed {
+          if [$self is_failure] {
+            eval [concat $cb_code [list $failure]]
+          }
+        }
+      }
+    }
+  }
+
+  method AssertReady {} {
+    if {!$is_ready} {
+      error "Future not ready"
+    }
+  }
+
+  method is_ready {} { return $is_ready }
+
+  method get {} {
+    $self AssertReady
+    if [$self is_failure] {
+      error $failure
+    }
+    return $result
+  }
+
+  method is_failure {} {
+    $self AssertReady
+    if [llength $failure] {
+      return 1
+    }
+    return 0
+  }
+
+  method failure {} {
+    $self AssertReady
+    return $failure
+  }
+
+  method await {} {
+    vwait "${selfns}::is_ready"
+  }
+}
 
 snit::type ten::read_channel {
   option -fh
@@ -53,4 +171,4 @@ snit::type ten::read_channel {
   }
 }
 
-package provide ten 0.0.01
+package provide ten 0.0.1
diff --git a/ten/test.tcl b/ten/test.tcl
index c577494..3159c6e 100644
--- a/ten/test.tcl
+++ b/ten/test.tcl
@@ -14,10 +14,26 @@ namespace eval ::ten::test:: {
     puts stdout "not ok $test_count $reason"
   }
 
+  proc ok {cond reason} {
+    if $cond {
+      pass $reason
+    } else {
+      fail "$reason: $cond false"
+    }
+  }
+
+  proc cmp_ok {op left right reason} {
+    if [expr $left $op $right] {
+      pass $reason
+    } else {
+      fail "$reason: $left $op $right false"
+    }
+  }
+
   proc is {left right reason} {
     switch $left \
       $right { pass $reason } \
-      default { fail "$reason: expected $left, got $right" }
+      default { fail "$reason: expected $right, got $left" }
   }
 
   proc done_testing {} {
@@ -25,7 +41,7 @@ namespace eval ::ten::test:: {
     puts stdout "1..$test_count"
   }
 
-  namespace export pass fail is done_testing
+  namespace export pass fail is ok cmp_ok done_testing
 }
 
 package provide ten::test 0.0.1