diff options
author | William Joye <wjoye@cfa.harvard.edu> | 2017-10-26 16:44:17 (GMT) |
---|---|---|
committer | William Joye <wjoye@cfa.harvard.edu> | 2017-10-26 16:44:17 (GMT) |
commit | 79d64f400391ce81b4eda73977cb40099256b348 (patch) | |
tree | 47afaed270cf59335dbaf4eb7965eac64a02a687 /xpa/test.tcl | |
parent | 1377ae8b2142276c24d28d65865e459038984c62 (diff) | |
download | blt-79d64f400391ce81b4eda73977cb40099256b348.zip blt-79d64f400391ce81b4eda73977cb40099256b348.tar.gz blt-79d64f400391ce81b4eda73977cb40099256b348.tar.bz2 |
upgrade XPA
Diffstat (limited to 'xpa/test.tcl')
-rw-r--r-- | xpa/test.tcl | 261 |
1 files changed, 0 insertions, 261 deletions
diff --git a/xpa/test.tcl b/xpa/test.tcl deleted file mode 100644 index bfc413c..0000000 --- a/xpa/test.tcl +++ /dev/null @@ -1,261 +0,0 @@ -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 - - |