test: Run secnet under strace

[secnet.git] / test / invoke

diff --git a/test/invoke b/test/invoke
index 592053243caa036d7110f62f1b7f7522a538ae47..6678bb6e1ae460c020b2f86b00f3a19daeda9a8e 100755 (executable)
--- a/test/invoke
+++ b/test/invoke
@@ -2,6 +2,8 @@
 
 package require Tclx
 
+load chiark_tcl_hbytes-1.so
+
 set netlink(inside) {
     local-address "172.18.232.9";
     secnet-address "172.18.232.10";
@@ -23,11 +25,12 @@ set extra(inside) {
 set extra(outside) {}
 
 proc mkconf {which} {
+    global tmp
     global netlink
     global ports
     global extra
     global netlinkfh
-    set pipefp test/$which.netlink
+    set pipefp $tmp/$which.netlink
     foreach tr {t r} {
        file delete $pipefp.$tr
        exec mkfifo -m600 $pipefp.$tr
@@ -35,11 +38,12 @@ proc mkconf {which} {
        fconfigure $fh -blocking 0 -buffering none -translation binary
     }
     fileevent $netlinkfh($which.r) readable [list netlink-readable $which]
-    set fakeuf test/$which.fake-userv
+    set fakeuf $tmp/$which.fake-userv
     set fakeuh [open $fakeuf w 0755]
     puts $fakeuh "#!/bin/sh
 set -e
-cat >$pipefp.r &
+exec 3<&0
+cat <&3 3<&- >$pipefp.r &
 exec 3<>$pipefp.t
 exec <$pipefp.t
 exec 3<&-
@@ -92,17 +96,18 @@ exec cat
 
 proc spawn-secnet {which} {
     global netlinkfh
+    global tmp
     upvar #0 pids($which) pid
-    set cf test/$which.conf
+    set cf $tmp/$which.conf
     set ch [open $cf w]
     puts $ch [mkconf $which]
     close $ch
-    set argl [list -dvnc $cf]
+    set argl [list strace -o$tmp/$which.strace ./secnet -dvnc $cf]
     set pid [fork]
     if {!$pid} {
-       execl ./secnet $argl
+       execl [lindex $argl 0] [lrange $argl 1 end]
     }
-    puts -nonewline $netlinkfh($which.t) "\xc0"
+    puts -nonewline $netlinkfh($which.t) [hbytes h2raw c0]
 }
 
 proc netlink-readable {which} {
@@ -110,18 +115,54 @@ proc netlink-readable {which} {
     upvar #0 netlinkfh($which.r) fh
     read $fh; # empty the buffer
     switch -exact $which {
-       outside {
+       inside {
            puts OK
            set ok 1; # what a bodge
            return
        }
-       inside {
+       outside {
            error "inside rx'd!"
        }
     }
 }
 
+proc bgerror {message} {
+    global errorInfo errorCode
+    catch {
+       puts stderr "
+----------------------------------------
+$errorInfo
+
+$errorCode
+$message
+----------------------------------------
+    "
+    }
+    exit 1
+}
+
+proc sendpkt {} {
+    global netlinkfh
+    set p {
+        4500 0054 ed9d 4000 4001 24da ac12 e809
+        ac12 e802 0800 1de4 2d96 0001 f1d4 a05d
+        0000 0000 507f 0b00 0000 0000 1011 1213
+        1415 1617 1819 1a1b 1c1d 1e1f 2021 2223
+        2425 2627 2829 2a2b 2c2d 2e2f 3031 3233
+        3435 3637
+    }
+    puts -nonewline $netlinkfh(inside.t) \
+       [hbytes h2raw c0[join $p ""]c0]
+}
+
+file mkdir test/tmp
+set tmp test/tmp
+
 spawn-secnet inside
 spawn-secnet outside
 
+after 500 sendpkt
+after 1000 sendpkt
+after 5000 timed-out
+
 vwait ok