From: Matt S Trout <mst@shadowcat.co.uk>
Date: Sat, 4 Aug 2012 16:09:53 +0000 (+0000)
Subject: initial harness code and read channel
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=3c6a0ce7ac46c66d6b7b48d63cbfc0470ae991e1;p=scpubgit%2FTenDotTcl.git

initial harness code and read channel
---

diff --git a/t/000-harness-sanity.t b/t/000-harness-sanity.t
new file mode 100644
index 0000000..70fb0c5
--- /dev/null
+++ b/t/000-harness-sanity.t
@@ -0,0 +1,5 @@
+BEGIN { exec(tclsh => 't/tcl/harness.tcl' => $0) }
+
+pass "This is a passing test"
+
+done_testing
diff --git a/t/readch.t b/t/readch.t
new file mode 100644
index 0000000..288d3f3
--- /dev/null
+++ b/t/readch.t
@@ -0,0 +1,33 @@
+BEGIN { exec(tclsh => 't/tcl/harness.tcl' => $0) }
+
+package require ten
+
+set tfh [open {|./echo.pl} r+]
+
+fconfigure $tfh -buffering line
+
+set rch [ten::read_channel %AUTO% -fh $tfh]
+
+proc line_cb {line} {
+  global got_line
+  set got_line $line
+}
+
+puts $tfh foo
+
+$rch configure -on_line_call line_cb
+
+global got_line
+
+vwait got_line
+
+is $got_line foo "Got line from read channel (send before set cb)"
+
+puts $tfh bar
+
+vwait got_line
+
+is $got_line bar "Got line from read channel (send after set cb)"
+
+done_testing
+
diff --git a/t/tcl/harness.tcl b/t/tcl/harness.tcl
new file mode 100644
index 0000000..2856a1c
--- /dev/null
+++ b/t/tcl/harness.tcl
@@ -0,0 +1,5 @@
+lappend ::auto_path snit ten
+package require ten::test
+namespace import ten::test::*
+proc BEGIN {meh} {}
+source [lindex $argv 0]
diff --git a/t/tcl/perlharness.pl b/t/tcl/perlharness.pl
new file mode 100644
index 0000000..5a9bedf
--- /dev/null
+++ b/t/tcl/perlharness.pl
@@ -0,0 +1 @@
+exec('tclsh','t/tcl/harness.tcl',$0);
diff --git a/ten/pkgIndex.tcl b/ten/pkgIndex.tcl
new file mode 100644
index 0000000..6cfd726
--- /dev/null
+++ b/ten/pkgIndex.tcl
@@ -0,0 +1,2 @@
+package ifneeded ten 0.0.1 [list source [file join $dir ten.tcl]]
+package ifneeded ten::test 0.0.1 [list source [file join $dir test.tcl]]
diff --git a/ten/ten.tcl b/ten/ten.tcl
new file mode 100644
index 0000000..184b161
--- /dev/null
+++ b/ten/ten.tcl
@@ -0,0 +1,56 @@
+package require Tcl 8.4
+
+package require snit
+
+namespace eval ::ten:: {
+  set library [file dirname [info script]]
+}
+
+snit::type ten::connector::perl {
+
+  method connect {} {
+    set conn_fh [open {|object-remote-node} r+]
+    set firstline [gets conn_fh]
+    switch $firstline {
+      Shere {}
+      default { error "Expected Shere, got $firstline" }
+    }
+
+    set channel [ten::read_channel %AUTO% -fh $conn_fh]
+
+    set conn [
+      ten::connection %AUTO% -send_to_fh $conn_fh -read_channel $channel
+    ]
+
+    return $conn
+  }
+} 
+
+snit::type ten::read_channel {
+  option -fh
+  option -on_close_call
+  option -on_line_call
+
+  constructor {args} {
+    $self configurelist $args
+    fconfigure $options(-fh) -blocking 0
+    fileevent $options(-fh) readable [mymethod ReceiveData]
+  }
+
+  method ReceiveData {} {
+    set chan $options(-fh)
+    if [eof $chan] {
+      if [llength $options(-on_close_call)] {
+        eval $options(-on_close_call)
+      }
+    } else {
+      if [llength $options(-on_line_call)] {
+        while {[llength [set line [gets $chan]]] > 0} {
+          eval [concat $options(-on_line_call) $line]
+        }
+      }
+    }
+  }
+}
+
+package provide ten 0.0.01
diff --git a/ten/test.tcl b/ten/test.tcl
new file mode 100644
index 0000000..c577494
--- /dev/null
+++ b/ten/test.tcl
@@ -0,0 +1,31 @@
+namespace eval ::ten::test:: {
+
+  variable test_count 0
+
+  proc pass {reason} {
+    variable test_count
+    incr test_count
+    puts stdout "ok $test_count $reason"
+  }
+
+  proc fail {reason} {
+    variable test_count
+    incr test_count
+    puts stdout "not ok $test_count $reason"
+  }
+
+  proc is {left right reason} {
+    switch $left \
+      $right { pass $reason } \
+      default { fail "$reason: expected $left, got $right" }
+  }
+
+  proc done_testing {} {
+    variable test_count
+    puts stdout "1..$test_count"
+  }
+
+  namespace export pass fail is done_testing
+}
+
+package provide ten::test 0.0.1