archie/tcl-dp/tests/rpc.test
2024-05-27 16:13:40 +02:00

330 lines
8.8 KiB
Plaintext

#########################################
#
# RPC test suite for Tcl-DP 4.0
#
if {[string compare test [info procs test]] == 1} then {source defs}
source ../library/rpc.tcl
source ../library/dp_atexit.tcl
catch {source ../library/dp_atclose.tcl}
source make-server
proc MyCheck {args} {}
proc fileserv {filename} {
set openfile [open $filename r]
read $openfile
}
catch {dp_atexit clear}
set hostinet [dp_netinfo -address $hostname]
#----------------------------------------------------------------------
#
# Connectivity tests
#
test rpc-1.1 {creation of rpc client using hostname} {
list [catch {
set server1 [dp_MakeRPCClient $hostname $S_PORT]
string match tcp* $server1
} msg] $msg
} {0 1}
test rpc-1.2 {creation of rpc client using internet address} {
list [catch {
set server2 [dp_MakeRPCClient $hostinet $S_PORT]
string match tcp* $server2
} msg] $msg
} {0 1}
# This if controls whether the rest of the tests will be performed.
#
if {[string match tcp* $server1] & [string match tcp* $server2]} {
#------------------------------------------------------------------------------
#
# Basic message passing tests
#
test rpc-2.1 {Basic message passing} {
list [catch {
dp_RPC $server1 set mike rules
} msg] $msg
} {0 rules}
test rpc-2.2 {basic error handling} {
list [catch {
dp_RPC $server1 set a
} msg] $msg
} {1 {can't read "a": no such variable}}
test rpc-2.3 {timeout routines} {
list [catch {
catch { dp_RPC $server1 -timeout 50 after 1000 } msg
string match "RPC timed out on channel tcp*" $msg
} msg] $msg
} {0 1}
proc errorTest {file} {
return "Caught error on $file"
}
test rpc-2.4 {timeout routines} {
list [catch {
set rc [dp_RPC $server1 -timeout 50 -timeoutReturn errorTest after 1000]
string match "Caught error on tcp*" $rc
} msg] $msg
} {0 1}
# tests dp_CancelRPC when it's given a filehandle and when it isn't
test rpc-2.5 {cancel rpc test} {
after idle dp_CancelRPC $server1
catch {dp_RPC $server1 -timeout 5000 -timeoutReturn puts -events idle after 5000} msg
after idle dp_CancelRPC all
catch {dp_RPC $server1 -timeout 5000 -timeoutReturn puts -events idle after 5000} msg1
set xx [list [string match "RPC cancelled on channel tcp*" $msg] \
[string match "RPC cancelled on channel tcp*" $msg1] ]
} {1 1}
# this test tells the remote server to open up another socket, using
# dp_connect -server and dp_accept (at the server!). Then it calls
# the new connection to make sure that RPCs work.
test rpc-2.6 {RPC test} {
global id remfile newfile
list [catch {
# tell the remote interpreter to open up another listening server
set id [dp_RPC $server1 dp_connect tcp -server true -myport 9901]
set port [dp_RPC $server1 fconfigure $id -myport]
dp_RDO $server1 eval "set remfile \[lindex \[dp_accept $id\] 0\]"
# connect to the new server, get both the file representing the
# connection on this side ($newfile) and on the remote side ($remfile)
set newfile [dp_connect tcp -host $hostname -port 9901]
dp_admin register $newfile
set remfile [dp_RPC $server1 set remfile]
catch {dp_RPC $server1 dp_admin register $remfile} msg
# send a simple RPC
dp_RPC $newfile set test 33
# now use the original RPC connection to test whether the other RPC
# worked.
list [catch {
dp_RPC $server1 -timeout 10000 -timeoutReturn puts set test
} msg]
} msg2] [list $msg2 $msg]
} {0 {0 33}}
# this tests if we will correctly handle
# multiple RPCs while waiting. Also tests what happens when
# a badly formatted RPC packet is sent to the socket waiting
# for rpc messages. Third, tests if RPCs can handle getting
# return values in multiple packets.
test rpc-2.7 {multiple RPCs with waiting} {
list [catch {
global id remfile newfile
for {set i 0} {$i < 500} {incr i} {
dp_RPC $newfile set a $i
}
# set up the fileserver proc on the remoter server
dp_RPC $newfile proc fileserv {filename} {
set openfile [open $filename r]
read $openfile
}
# read over a large file (dpRPC.c) to force dp_RPC to get
# it's return value in multiple packets.
cd ..
set path [pwd]
set filename $path/generic/dpRPC.c
cd tests
dp_RPC $newfile fileserv $filename
catch {dp_RPC $newfile -timeout 10 fileserv $filename}
dp_RPC $newfile dp_RPC $remfile set a 33
set result [dp_RPC $newfile set a]
list $a $result
} msg2] $msg2
} {0 {33 499}}
after idle catch {close $newfile}
# tests to make sure nested RPC's are allowed
test rpc-2.8 {nested RPC test} {
list [catch {
dp_RPC $server1 set a 100
after idle {catch {dp_RPC $server1 set a 9} msg}
dp_RPC $server1 -events {rpc idle} after 5000
set a [dp_RPC $server1 set a]
list $a $msg
} msg2] $msg2
} {0 {9 9}}
# a silly little test to make sure dp correctly processes all event flags.
test rpc-2.9 {rpc event list test} {
list [catch {
dp_RPC $server1 -events [list x rpc file timer idle all none] set a 9
} msg] $msg
} {0 9}
#------------------------------------------------------------------------------
#
# RDO tests
#
test rpc-3.1 {Basic RDO} {
list [catch {
dp_RPC $server1 catch {unset a}
dp_RDO $server1 set a rpc-3.1
dp_RPC $server1 set a
} msg] $msg
} {0 rpc-3.1}
test rpc-3.2 {Basic RDO with callback} {
list [catch {
set rdoResults 0
dp_RDO $server1 set a rpc-3.2
dp_RDO $server1 -callback "set rdoResults" set a
dp_RPC $server1 set a synchronize
set rdoResults
} msg] $msg
} {0 rpc-3.2}
test rpc-3.3 {Multiple RDOs, each with callback} {
list [catch {
set RDO1 0
set RDO2 0
dp_RDO $server1 -callback "set RDO1" set a 3.3a
dp_RDO $server1 -callback "set RDO2" set a 3.3b
dp_RPC $server1 -events all set a synchronize
list $RDO1 $RDO2
} msg] $msg
} {0 {3.3a 3.3b}}
test rpc-3.4 {Basic RDO error handling} {
list [catch {
set RDOerr 0
dp_RDO $server1 unset a
dp_RDO $server1 -onerror "set RDOerr" set a
dp_RPC $server1 set a synchronize
set RDOerr
} msg] $msg
} {0 {can't read "a": no such variable}}
test rpc-3.5 {Basic RDO error generation (error will crash test)} {
list [catch {
unset msg
dp_RPC $server1 -events all unset a
catch {dp_RDO $server1 -onerror none set a}
} msg] $msg
} {0 0}
test rpc-3.6 {RDO error handling for multiple RDO's} {
list [catch {
set RDOerr1 rpc-3.6a
set RDOerr2 rpc-3.6b
dp_RDO $server1 -onerror none unset a
dp_RDO $server1 -onerror none unset b
dp_RDO $server1 -onerror "set RDOerr1" set a
dp_RDO $server1 -onerror "set RDOerr2" set b
dp_RPC $server1 set a synchronize
list $RDOerr1 $RDOerr2
} msg] $msg
} {0 {{can't read "a": no such variable} {can't read "b": no such variable}}}
test rpc-3.7 {RDO callback handling for multiple RDO's} {
list [catch {
set RDO1 rpc3.7a
set RDO2 rpc3.7b
dp_RDO $server1 set a rpc3.7c
dp_RDO $server1 -onerror none unset b
dp_RDO $server1 -onerror none -callback "set RDO1" set a
dp_RDO $server1 -onerror none -callback "set RDO2" set b
dp_RPC $server1 set a synchronize
list $RDO1 $RDO2
} msg] $msg
} {0 {rpc3.7c rpc3.7b}}
test rpc-3.8 {Mixed RDO error and callback handling for multiple RDO's} {
list [catch {
set RDOerr1 rpc3.8a
set RDOerr2 rpc3.8b
set RDO1 rpc3.8c
set RDO2 rpc3.8d
dp_RDO $server1 set a hello
dp_RDO $server1 -onerror none unset b
dp_RDO $server1 -callback "set RDO1" -onerror "set RDOerr1" set a
dp_RDO $server1 -callback "set RDO2" -onerror "set RDOerr2" set b
dp_RPC $server1 set a synchronize
list $RDOerr1 $RDOerr2 $RDO1 $RDO2
} msg] $msg
} {0 {rpc3.8a {can't read "b": no such variable} hello rpc3.8d}}
test rpc-3.9 {mixed RPC and RDO with timeout} {
list [catch {
set RDO1 rpc3.9a
set RDO2 rpc3.9b
dp_RDO $server1 -callback "set RDO1" set a rpc3.9c
set rv1 [catch {dp_RPC $server1 -timeout 50 after 1000} msg1]
dp_RDO $server1 -callback "set RDO2" set a rpc3.9d
set rv2 [catch {dp_RPC $server1 set a rpc3.9e} msg2]
set msg2 [string match "RPC timed out*" $msg1]
list $rv1 $rv2 $RDO1 $RDO2
} msg] $msg
} {0 {1 0 rpc3.9c rpc3.9d}}
#------------------------------------------------------------------------------
#
# Shutdown protocol tests
#
test rpc-4.1 {proper closing one end of an RPC} {
list [catch {
close $server1
} msg] $msg
} {0 {}}
test rpc-4.2 {check dp_atexit list} {
list [catch {
string match "\{close $server2\}" [dp_atexit list]
} msg] $msg
} {0 1}
test rpc-4.3 {close the remote interpreter} {
list [catch {
dp_RDO $server2 exit
} msg] $msg
} {0 {}}
catch {close $server2}
test rpc-4.4 {check dp_atclose list} {
list [catch {
list [dp_atclose $server1 list] [dp_atclose $server2 list]
} msg] $msg
} {0 {{} {}}}
test rpc-4.5 {check server crashing} {
list [
set rc [catch {close $server1} msg1]
string match "can not find channel named*" $msg1
] $rc
} {1 1}
} else {
# reset variable so server will quit also
# just in case the channel is still viable.
catch {dp_RDO $server1 set forever 42}
return
}