diff options
Diffstat (limited to 'xpa/test.tcl')
| -rw-r--r-- | xpa/test.tcl | 261 |
1 files changed, 261 insertions, 0 deletions
diff --git a/xpa/test.tcl b/xpa/test.tcl new file mode 100644 index 0000000..bfc413c --- /dev/null +++ b/xpa/test.tcl @@ -0,0 +1,261 @@ +lappend auto_path . + +package require tclxpa 2.1 + +# set rmode "fillbuf=false" +set rmode "" +set imode "" + +set smode "" +set sbuf "initial message\n" +set slen [string length $sbuf] +set schan "" + +set n 0 + +proc DoIt {xpa cdata param buf len} { + puts [format "entering %s" $cdata] + tk_messageBox -parent . -type ok -message "$cdata" + puts [format "exiting %s" $cdata] +} + +proc reccb { xpa client_data paramlist buf len }\ +{ + global sbuf slen rmode n + global sfile sfilebuf schan + puts " " + puts [format "Entering receive callback routine %s" $n] + puts [format "xpa class: %s" [xparec $xpa class]] + puts [format "xpa name: %s" [xparec $xpa name]] + puts [format "xpa method: %s" [xparec $xpa method]] + puts [format "xpa cmdfd: %s" [xparec $xpa cmdfd]] + puts [format "xpa cmdchan: %s" [xparec $xpa cmdchan]] + puts [format "xpa datafd: %s" [xparec $xpa datafd]] + puts [format "xpa datachan: %s" [xparec $xpa datachan]] + puts [format "xpa sendian: %s" [xparec $xpa sendian]] + puts [format "xpa cendian: %s" [xparec $xpa cendian]] + puts [format "client_data: %s" $client_data] + puts [format "paramlist: %s" $paramlist] + incr n + + if { $rmode == "fillbuf=false" } { + set dchan [xparec $xpa datachan] + fconfigure $dchan -translation binary + set mybuf [read $dchan] + set mylen [string length $mybuf] + puts [format "read %s bytes" $mylen] + set sbuf $mybuf + set slen $mylen + if { $mylen < 512 } { + puts $mybuf + } else { + xpaerror $xpa [format "Jeez! %s is too many bytes" $mylen] + return -code error + } + } else { + puts [format "entering with %s bytes" $len] + if { $len < 512 } { + puts $buf + } + set sbuf $buf + set slen $len + } + if { $paramlist == "open" } { + if { $schan != "" } { + close $schan + } + set sfile [string trimright $sbuf] + set schan [open $sfile r] + set sfilebuf [read $schan] + puts [format "read %d bytes from '%s'" [string length $sfilebuf] $sfile] + } +} + +proc sendcb { xpa client_data paramlist }\ +{ + global sbuf slen n + puts " " + puts [format "Entering send callback routine %s for %s" $n $xpa] + puts [format "xpa class: %s" [xparec $xpa class]] + puts [format "xpa name: %s" [xparec $xpa name]] + puts [format "xpa method: %s" [xparec $xpa method]] + puts [format "xpa cmdfd: %s" [xparec $xpa cmdfd]] + puts [format "xpa cmdchan: %s" [xparec $xpa cmdchan]] + puts [format "xpa datafd: %s" [xparec $xpa datafd]] + puts [format "xpa datachan: %s" [xparec $xpa datachan]] + puts [format "xpa sendian: %s" [xparec $xpa sendian]] + puts [format "xpa cendian: %s" [xparec $xpa cendian]] + puts [format "client_data: %s" $client_data] + puts [format "paramlist: %s" $paramlist] + incr n + + if { $slen > 0 } { + puts [format "sending %s bytes of data" $slen] + xpasetbuf $xpa $sbuf $slen + } else { + xpaerror $xpa [format "no data to send from %s\n" $client_data] + return -code error + } +} + +proc infocb { xpa client_data paramlist }\ +{ + puts " " + puts "Entering info callback routine" + puts [format "xpa class: %s" [xparec $xpa class]] + puts [format "xpa name: %s" [xparec $xpa name]] + puts [format "xpa method: %s" [xparec $xpa method]] + puts [format "xpa sendian: %s" [xparec $xpa sendian]] + puts [format "xpa cendian: %s" [xparec $xpa cendian]] + puts [format "client_data: %s" $client_data] + puts [format "paramlist: %s" $paramlist] +} + +if { [info exists class] == 0 } { + set class "XPA" +} +puts [format "class: %s" $class] + +if { [info exists name] == 0 } { + set name "xpa" +} +puts [format "name: %s" $name] + +if { [info exists initxpa] } { + +puts "initializing xpa access points ..." + +set xpa [xpanew [format "%s" $class] [format "%s" $name] "xpa1 help" \ + sendcb "xpa1" $smode reccb "xpa1" $rmode] +puts [format "xpa=%s" $xpa] + +set xpa1 [xpanew [format "%s" $class] [format "%s1" $name] "xpa1a help" \ + sendcb "xpa1a" $smode reccb "xpa1a" $rmode] +puts [format "xpa1=%s" $xpa1] + +set xpac [xpacmdnew [format "%s" $class] [format "%sc" $name]] +puts [format "xpac=%s" $xpac] + +set cmd1 [xpacmdadd $xpac "cmd1" "cmd1 help" \ + sendcb "xpac/cmd1" $smode reccb "xpac/cmd1" $rmode] +puts [format "cmd1=%s" $cmd1] + +set cmd2 [xpacmdadd $xpac "cmd2" "cmd2 help" \ + sendcb "xpac/cmd2" $smode reccb "xpac/cmd2" $rmode] +puts [format "cmd2=%s" $cmd2] + +set cmd3 [xpacmdadd $xpac cmd3 "help cmd 3" "" "" "" DoIt "cmd 3" ""] +puts [format "cmd3=%s" $cmd3] + +set cmd4 [xpacmdadd $xpac cmd4 "help cmd 4" "" "" "" DoIt "cmd 4" ""] +puts [format "cmd4=%s" $cmd4] + +set xpai [xpainfonew XPA [format "%si" $name] infocb "xpai" $imode] +puts [format "xpai=%s" $xpai] + +} + +proc getloop { xpa loops } { + for {set i 0} {$i < $loops} {incr i} { + set got [xpaget "" $xpa [format "testing xpaget %s" $i] \ + "" bufs lens names errs 10] + for {set j 0} {$j < $got} {incr j} { + set err [lindex $errs $j] + if { $err != "" } { + puts $err + } else { + set buf [lindex $bufs $j] + puts [format "return buf %s: %s" $j $buf] + } + } + } +} + +proc setloop { loops } { + for {set i 0} {$i < $loops} {incr i} { + set got [xpaset "" "xpa*" [format "testing xpaset %s" $i] \ + "" "dummy buffer" "" names errs 10] + puts $names + } +} + +proc infoloop { loops } { + for {set i 0} {$i < $loops} {incr i} { + set got [xpainfo "" "i_xpa" [format "testing xpainfo %s" $i] \ + "" names errs 10] + puts $names + } +} + +if { 0 } { + set got [xpaget "" "xpa1" "this is a test" "" bufs lens names errs 10] + puts $got + puts $lens + puts $bufs + + set got [xpaset "" "xpa1" "test" "" "this is a test" "" names errs 10] + puts $got + puts $errs + + set got [xpainfo "" "i_xpa" "info test" "" names errs 10] + puts $got + puts $errs + + set got [xpaaccess "" "xpa*" "" "" names errs 10] + puts $got + puts $names + puts $errs + + set xpa [xpaopen ""] + set got [xpaset $xpa "xpa1" "test" "" "this is a test" "" names errs 10] + set got [xpainfo $xpa xpai "info test" "" names errs 10] + xpaclose $xpa + + set wchan1 [open foo1.log w+] + set wchan2 [open foo2.log w+] + set wchans [list $wchan1 $wchan2] + set got [xpagetfd "" "xpa1" "this is a test" "" $wchans names errs 10] + set got [xpasetfd "" "xpa1" "this is a test" "" $rchan names errs 10] + set got [xpanslookup "xpa1" "" classes names methods] +} + +proc wsbuf { fname } { + global sbuf + set fid [open $fname w 0600] + puts -nonewline $fid $sbuf + close $fid +} + +set _xpakeepalive 1 +proc xpakeepalive { xpa sec {type 0} } { + global _xpakeepalive + if { $_xpakeepalive > 0 } { + puts "sending keepalive ..." + xpanskeepalive $xpa $type + after [expr $sec * 1000] xpakeepalive $xpa $sec $type + } +} + +proc katest { host sec {type 0} } { + global xpa + xparemote $xpa $host + -proxy + after [expr $sec * 1000] xpakeepalive $xpa $sec $type +} + +if { 0 } { + puts "You can now execute:" + puts " " + puts " katest bynars.harvard.edu:28571 60" + puts " (if this is tclsh, you need to run vwait)" + # katest bynars.harvard.edu:28571 60 + puts " " + puts "or:" + puts " " + puts " xparemote $xpa bynars.harvard.edu:28571 + -proxy" + puts " " + # xparemote $xpa bynars.harvard.edu:28571 + -proxy +} + +# vwait forever + + |