Intial commit
This commit is contained in:
Mario Fetka
BIN
tcl-dp/tests/00-first.test
Normal file
BIN
tcl-dp/tests/00-first.test
Normal file
Binary file not shown.
28
tcl-dp/tests/all
Normal file
28
tcl-dp/tests/all
Normal file
@@ -0,0 +1,28 @@
|
||||
# This file contains a top-level script to run all of the Tcl
|
||||
# tests. Execute it by invoking "source all" when running tclTest
|
||||
# in this directory.
|
||||
#
|
||||
|
||||
set script [info script]
|
||||
if [string match *all $script] {
|
||||
if [string comp $script "all"] {
|
||||
catch {
|
||||
cd [file dirname $script]
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
foreach i [lsort [glob *.test]] {
|
||||
puts stdout $i
|
||||
source $i
|
||||
}
|
||||
|
||||
if {![string comp $argv "all"]} {
|
||||
exit 1
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
39
tcl-dp/tests/connect.test
Normal file
39
tcl-dp/tests/connect.test
Normal file
@@ -0,0 +1,39 @@
|
||||
# connect.test --
|
||||
#
|
||||
# This file tests the dp_connect and dp_accept commands.
|
||||
#
|
||||
|
||||
if {[string compare test [info procs test]] == 1} then {source ../tests/defs}
|
||||
set VERBOSE 1
|
||||
|
||||
if {$win == 1} {
|
||||
|
||||
test connect-1.1 {dp_connect command} {
|
||||
list [catch {dp_connect} msg] $msg
|
||||
} {1 {wrong # args: should be "dp_connect channelType ?args ...?"
|
||||
Valid channel types are: packoff serial udp plugfilter identity tcp ipm }}
|
||||
|
||||
test connect-1.2 {dp_connect command} {
|
||||
list [catch {dp_connect foobar} msg] $msg
|
||||
} {1 {Unknown channel type "foobar"
|
||||
Valid channel types are: packoff serial udp plugfilter identity tcp ipm }}
|
||||
|
||||
} else {
|
||||
|
||||
test connect-1.1 {dp_connect command} {
|
||||
list [catch {dp_connect} msg] $msg
|
||||
} {1 {wrong # args: should be "dp_connect channelType ?args ...?"
|
||||
Valid channel types are: packoff serial udp plugfilter identity email tcp ipm }}
|
||||
|
||||
test connect-1.2 {dp_connect command} {
|
||||
list [catch {dp_connect foobar} msg] $msg
|
||||
} {1 {Unknown channel type "foobar"
|
||||
Valid channel types are: packoff serial udp plugfilter identity email tcp ipm }}
|
||||
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
114
tcl-dp/tests/copy.test
Normal file
114
tcl-dp/tests/copy.test
Normal file
@@ -0,0 +1,114 @@
|
||||
# copy.test
|
||||
#
|
||||
# This file tests the dp_copy command.
|
||||
#
|
||||
|
||||
if {[string compare test [info procs test]] == 1} then {source ../tests/defs}
|
||||
|
||||
set argsError {wrong # args: should be "dp_copy ?-size size? inChanId outChanId ?outChanId ...?"}
|
||||
|
||||
test copy-1.1 {dp_copy command} {
|
||||
list [catch {dp_copy} msg] $msg
|
||||
} [list 1 $argsError]
|
||||
|
||||
test copy-1.2 {dp_copy command} {
|
||||
list [catch {dp_copy foo} msg] $msg
|
||||
} [list 1 $argsError]
|
||||
|
||||
test copy-1.3 {dp_copy command} {
|
||||
list [catch {dp_copy -size 1000 foo} msg] $msg
|
||||
} [list 1 $argsError]
|
||||
|
||||
test copy-1.4 {dp_copy command} {
|
||||
list [catch {dp_copy -size foo} msg] $msg
|
||||
} {1 {expected integer but got "foo"}}
|
||||
|
||||
test copy-1.5 {dp_copy command} {
|
||||
list [catch {dp_copy -size stdin} msg] $msg
|
||||
} {1 {expected integer but got "stdin"}}
|
||||
|
||||
test copy-2.1 {create temp file for testing} {
|
||||
set tmpfd [open testtmp.00 {CREAT TRUNC WRONLY}]
|
||||
puts -nonewline $tmpfd "0123456789"
|
||||
puts $tmpfd ".........."
|
||||
puts $tmpfd "abcd..abcd"
|
||||
close $tmpfd
|
||||
set dp_copyTmpFileGood 1
|
||||
} 1
|
||||
|
||||
catch {close $tmpfd}
|
||||
|
||||
if ![info exists dp_copyTmpFileGood] {
|
||||
puts stderr "Cannot create temporary file. Some tests of dp_copy are "
|
||||
puts stderr "skipped."
|
||||
catch {
|
||||
file delete testtmp.00
|
||||
}
|
||||
return
|
||||
}
|
||||
|
||||
test copy-2.2 {dp_copy command} {
|
||||
set ifd [open testtmp.00 {RDONLY}]
|
||||
set ofd [open testtmp.01 {CREAT TRUNC WRONLY}]
|
||||
|
||||
dp_copy -size 10 $ifd $ofd
|
||||
close $ifd
|
||||
close $ofd
|
||||
|
||||
set ofd [open testtmp.01 {RDONLY}]
|
||||
gets $ofd
|
||||
} "0123456789"
|
||||
|
||||
catch {close $ifd}
|
||||
catch {close $ofd}
|
||||
|
||||
test copy-2.3 {dp_copy command} {
|
||||
set ifd [open testtmp.00 {RDONLY}]
|
||||
set ofd [open testtmp.01 {CREAT TRUNC WRONLY}]
|
||||
|
||||
dp_copy -size 10 $ifd $ofd
|
||||
dp_copy -size 15 $ifd $ofd
|
||||
close $ifd
|
||||
close $ofd
|
||||
|
||||
set ofd [open testtmp.01 {RDONLY}]
|
||||
set stuff "[gets $ofd][gets $ofd]"
|
||||
#
|
||||
# N.B. The newline character is discarded by gets
|
||||
#
|
||||
} "0123456789..........abcd"
|
||||
|
||||
catch {close $ifd}
|
||||
catch {close $ofd}
|
||||
|
||||
test copy-2.4 {dp_copy command} {
|
||||
set ifd [open testtmp.00 {RDONLY}]
|
||||
set ofd1 [open testtmp.01 {CREAT TRUNC WRONLY}]
|
||||
set ofd2 [open testtmp.02 {CREAT TRUNC WRONLY}]
|
||||
|
||||
dp_copy -size 10 $ifd $ofd1 $ofd2
|
||||
dp_copy -size 5 $ifd $ofd1 $ofd2
|
||||
dp_copy -size 10 $ifd $ofd1
|
||||
close $ifd
|
||||
close $ofd1
|
||||
close $ofd2
|
||||
|
||||
set ofd1 [open testtmp.01 {RDONLY}]
|
||||
set ofd2 [open testtmp.02 {RDONLY}]
|
||||
set stuff "[gets $ofd1][gets $ofd2][gets $ofd1][gets $ofd2]"
|
||||
|
||||
} "0123456789..........0123456789.....abcd"
|
||||
|
||||
catch {close $ifd}
|
||||
catch {close $ofd1}
|
||||
catch {close $ofd2}
|
||||
|
||||
catch {file delete testtmp.00}
|
||||
catch {file delete testtmp.01}
|
||||
catch {file delete testtmp.02}
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
208
tcl-dp/tests/defs
Normal file
208
tcl-dp/tests/defs
Normal file
@@ -0,0 +1,208 @@
|
||||
# defs --
|
||||
#
|
||||
# This file contains support code for the Tcl test suite. It is
|
||||
# normally sourced by the individual files in the test suite
|
||||
# before they run their tests. This improved approach to
|
||||
# testing was designed and initially implemented by Mary Ann
|
||||
# May-Pumphrey of Sun Microsystems.
|
||||
#
|
||||
|
||||
# The environment DP_TEST_VERBOSE can be used to control the verbosity
|
||||
# of the DP test suite. It must be a valid boolean number. With this
|
||||
# environment variable, you no longer have to edit the "defs" file
|
||||
# when you want to change the verbosity settings.
|
||||
#
|
||||
if [info exists env(DP_TEST_VERBOSE)] {
|
||||
if [catch {
|
||||
set VERBOSE [expr !(!($env(DP_TEST_VERBOSE)))]
|
||||
}] {
|
||||
set VERBOSE 0
|
||||
}
|
||||
} else {
|
||||
set VERBOSE 0
|
||||
}
|
||||
|
||||
set LOG 1
|
||||
set TESTS {}
|
||||
|
||||
if ![string comp [info commands package] ""] {
|
||||
puts stderr "This version of DP requires the package command."
|
||||
exit 1
|
||||
}
|
||||
|
||||
#
|
||||
# We require either Tcl 7.6 or Tcl 8.0
|
||||
#
|
||||
if {![info exists dp_version]} {
|
||||
|
||||
if [catch {package require Tcl 8.0} err] {
|
||||
if [catch {package require Tcl 7.6} err] {
|
||||
puts stderr $err
|
||||
exit 1
|
||||
}
|
||||
}
|
||||
|
||||
if ![info exists dp_version] {
|
||||
case $tcl_platform(platform) {
|
||||
unix {
|
||||
load ../unix/libdp40[info sharedlibextension] Dp
|
||||
}
|
||||
windows {
|
||||
load ../win/dp40.dll Dp
|
||||
}
|
||||
default {
|
||||
puts stderr \
|
||||
"DP is not supported on the \"$tcl_platform(platform)\" platform"
|
||||
exit 1
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
if {[string compare $tcl_platform(platform) "windows"] == 0} {
|
||||
set win 1
|
||||
} else {
|
||||
set win 0
|
||||
}
|
||||
|
||||
if {! [info exists tcl_msWindows]} {
|
||||
set tcl_msWindows 0
|
||||
}
|
||||
# If tests are being run as root, issue a warning message and set a
|
||||
# variable to prevent some tests from running at all.
|
||||
|
||||
set user {}
|
||||
catch {set user [exec whoami]}
|
||||
if {$user == "root"} {
|
||||
puts stdout "Warning: you're executing as root. I'll have to"
|
||||
puts stdout "skip some of the tests, since they'll fail as root."
|
||||
}
|
||||
|
||||
# Some of the tests don't work on some system configurations due to
|
||||
# configuration quirks, not due to Tcl problems; in order to prevent
|
||||
# false alarms, these tests are only run in the master source directory
|
||||
# at Cornell. The presence of a file "Cornell" in this directory is
|
||||
# used to indicate that these tests should be run.
|
||||
|
||||
set atCornell [file exists Cornell]
|
||||
|
||||
# If there is no "memory" command (because memory debugging isn't
|
||||
# enabled), generate a dummy command that does nothing.
|
||||
|
||||
if {[info commands memory] == ""} {
|
||||
proc memory args {}
|
||||
}
|
||||
|
||||
proc print_verbose {name description script code answer} {
|
||||
puts stdout "\n"
|
||||
puts stdout "==== $name $description"
|
||||
puts stdout "==== Contents of test case:"
|
||||
puts stdout "$script"
|
||||
if {$code != 0} {
|
||||
if {$code == 1} {
|
||||
puts stdout "==== Test generated error:"
|
||||
puts stdout $answer
|
||||
} elseif {$code == 2} {
|
||||
puts stdout "==== Test generated return exception; result was:"
|
||||
puts stdout $answer
|
||||
} elseif {$code == 3} {
|
||||
puts stdout "==== Test generated break exception"
|
||||
} elseif {$code == 4} {
|
||||
puts stdout "==== Test generated continue exception"
|
||||
} else {
|
||||
puts stdout "==== Test generated exception $code; message was:"
|
||||
puts stdout $answer
|
||||
}
|
||||
} else {
|
||||
puts stdout "==== Result was:"
|
||||
puts stdout "$answer"
|
||||
}
|
||||
}
|
||||
|
||||
# test --
|
||||
# This procedure runs a test and prints an error message if the
|
||||
# test fails. If VERBOSE has been set, it also prints a message
|
||||
# even if the test succeeds. The test will be skipped if it
|
||||
# doesn't match the TESTS variable, or if one of the elements
|
||||
# of "constraints" turns out not to be true.
|
||||
#
|
||||
# Arguments:
|
||||
# name - Name of test, in the form foo-1.2.
|
||||
# description - Short textual description of the test, to
|
||||
# help humans understand what it does.
|
||||
# constraints - A list of one or more keywords, each of
|
||||
# which must be the name of an element in
|
||||
# the array "testConfig". If any of these
|
||||
# elements is zero, the test is skipped.
|
||||
# This argument may be omitted.
|
||||
# script - Script to run to carry out the test. It must
|
||||
# return a result that can be checked for
|
||||
# correctness.
|
||||
# answer - Expected result from script.
|
||||
|
||||
proc test {name description script answer args} {
|
||||
global VERBOSE TESTS testConfig
|
||||
if {[string compare $TESTS ""] != 0} then {
|
||||
set ok 0
|
||||
foreach test $TESTS {
|
||||
if [string match $test $name] then {
|
||||
set ok 1
|
||||
break
|
||||
}
|
||||
}
|
||||
if !$ok then return
|
||||
}
|
||||
set i [llength $args]
|
||||
if {$i == 0} {
|
||||
# Empty body
|
||||
} elseif {$i == 1} {
|
||||
# "constraints" argument exists; shuffle arguments down, then
|
||||
# make sure that the constraints are satisfied.
|
||||
|
||||
set constraints $script
|
||||
set script $answer
|
||||
set answer [lindex $args 0]
|
||||
foreach constraint $constraints {
|
||||
if {![info exists testConfig($constraint)]
|
||||
|| !$testConfig($constraint)} {
|
||||
return
|
||||
}
|
||||
}
|
||||
} else {
|
||||
error "wrong # args: must be \"test name description ?constraints? script answer\""
|
||||
}
|
||||
memory tag $name
|
||||
set code [catch {uplevel $script} result]
|
||||
if {$code != 0} {
|
||||
print_verbose $name $description $script \
|
||||
$code $result
|
||||
} elseif {[string compare $result $answer] == 0} then {
|
||||
if {$VERBOSE > 1} {
|
||||
print_verbose $name $description $script \
|
||||
$code $result
|
||||
} elseif {$VERBOSE == 1} {
|
||||
puts stdout "++++ $name PASSED"
|
||||
}
|
||||
} else {
|
||||
print_verbose $name $description $script \
|
||||
$code $result
|
||||
puts stdout "---- Result should have been:"
|
||||
puts stdout "$answer"
|
||||
puts stdout "---- $name FAILED"
|
||||
}
|
||||
#
|
||||
# this is so that the screen updates immediately in wish
|
||||
#
|
||||
update idletasks
|
||||
}
|
||||
|
||||
proc dotests {file args} {
|
||||
global TESTS
|
||||
set savedTests $TESTS
|
||||
set TESTS $args
|
||||
source $file
|
||||
set TESTS $savedTests
|
||||
}
|
||||
|
||||
|
||||
|
||||
358
tcl-dp/tests/email.test
Normal file
358
tcl-dp/tests/email.test
Normal file
@@ -0,0 +1,358 @@
|
||||
# email.test
|
||||
#
|
||||
# This file tests the correct functioning of the email channels.
|
||||
#
|
||||
#
|
||||
# For unix systems: if this test fails, delete all files of the
|
||||
# form ~/.email*, and check the status of your ~/.forward file.
|
||||
#
|
||||
# Windows does not have an email channel
|
||||
#
|
||||
|
||||
if {$win == 1} {
|
||||
return
|
||||
}
|
||||
|
||||
# Set this to 1 if you want to test the email channel
|
||||
# and see the note below...
|
||||
|
||||
set testEmail 0
|
||||
if {$testEmail == 0} {
|
||||
puts stdout "*** Skipping email tests..."
|
||||
return
|
||||
}
|
||||
|
||||
|
||||
#
|
||||
# The user should define here his/her email address as the system defines it.
|
||||
# This version will work only if $USER@hostname is a valid email address for
|
||||
# the system DP is running on now.
|
||||
#
|
||||
|
||||
if {[catch {set myEmailAddress $env(USER)@cs.cornell.edu}]} {
|
||||
puts stdout "USER env. variable not set. Skipping email tests..."
|
||||
return;
|
||||
}
|
||||
|
||||
if {[string compare test [info procs test]] == 1} then {source ../tests/defs}
|
||||
|
||||
# set VERBOSE 1
|
||||
|
||||
test email-1.1.1 {dp_connect command} {
|
||||
list [catch {
|
||||
dp_connect email -bar
|
||||
} msg] $msg
|
||||
} {1 {unknown option "-bar", must be -address or -identifier}}
|
||||
|
||||
test email-1.1.2 {dp_connect command} {
|
||||
list [catch {
|
||||
dp_connect email -bar foo
|
||||
} msg] $msg
|
||||
} {1 {unknown option "-bar", must be -address or -identifier}}
|
||||
|
||||
#
|
||||
# Test argument missing checks.
|
||||
#
|
||||
|
||||
test email-1.2.1 {dp_connect command} {
|
||||
list [catch {
|
||||
dp_connect email -address
|
||||
} msg] $msg
|
||||
} {1 {value for "-address" missing}}
|
||||
|
||||
|
||||
test email-1.2.2 {dp_connect command} {
|
||||
list [catch {
|
||||
dp_connect email -identifier
|
||||
} msg] $msg
|
||||
} {1 {value for "-identifier" missing}}
|
||||
|
||||
|
||||
test email-1.2.3 {dp_connect command} {
|
||||
list [catch {
|
||||
dp_connect email
|
||||
} msg] $msg
|
||||
} {1 {address and/or identifier not defined for email channel}}
|
||||
|
||||
|
||||
test email-1.2.4 {dp_connect command} {
|
||||
list [catch {
|
||||
dp_connect email -address $myEmailAddress
|
||||
} msg] $msg
|
||||
} {1 {address and/or identifier not defined for email channel}}
|
||||
|
||||
|
||||
test email-1.2.5 {dp_connect command} {
|
||||
list [catch {
|
||||
dp_connect email -identifier 100
|
||||
} msg] $msg
|
||||
} {1 {address and/or identifier not defined for email channel}}
|
||||
|
||||
|
||||
#
|
||||
# Test type checking of arguments.
|
||||
#
|
||||
|
||||
test email-1.3.1 {dp_connect command} {
|
||||
list [catch {
|
||||
dp_connect email -address ""
|
||||
} msg] $msg
|
||||
} {1 {the address for an email channel can not be empty or start with a '*'}}
|
||||
|
||||
|
||||
test email-1.3.2 {dp_connect command} {
|
||||
list [catch {
|
||||
dp_connect email -address "*dp_list"
|
||||
} msg] $msg
|
||||
} {1 {the address for an email channel can not be empty or start with a '*'}}
|
||||
|
||||
|
||||
test email-1.3.3 {dp_connect command} {
|
||||
list [catch {
|
||||
dp_connect email -identifier 0
|
||||
} msg] $msg
|
||||
} {1 {the identifier for an email channel can not be zero, negative, or a string}}
|
||||
|
||||
test email-1.3.4 {dp_connect command} {
|
||||
list [catch {
|
||||
dp_connect email -identifier -45
|
||||
} msg] $msg
|
||||
} {1 {the identifier for an email channel can not be zero, negative, or a string}}
|
||||
|
||||
|
||||
test email-1.3.5 {dp_connect command} {
|
||||
list [catch {
|
||||
dp_connect email -identifier "just a string"
|
||||
} msg] $msg
|
||||
} {1 {expected integer but got "just a string"}}
|
||||
|
||||
|
||||
#
|
||||
#
|
||||
#
|
||||
#
|
||||
|
||||
set eChannel {}
|
||||
test email-1.4.1 {dp_connect command} {
|
||||
list [catch {
|
||||
set eChannel [dp_connect email -address $myEmailAddress -identifier 100]
|
||||
string range $eChannel 0 4
|
||||
} msg] $msg
|
||||
} {0 email}
|
||||
|
||||
|
||||
if {$eChannel != ""} {
|
||||
|
||||
|
||||
#
|
||||
# fconfigure tests
|
||||
#
|
||||
|
||||
|
||||
test email-1.4.2 {fconfigure email} {
|
||||
list [catch {
|
||||
fconfigure $eChannel
|
||||
} msg] $msg
|
||||
} {0 {-blocking 1 -buffering full -buffersize 4096 -eofchar {{} {}} -translation {auto lf} -address mperham@cs.cornell.edu -identifier 100 -peek 0 -sequence 0}}
|
||||
|
||||
|
||||
test email-1.4.3 {fconfigure email} {
|
||||
list [catch {
|
||||
fconfigure $eChannel -badopt
|
||||
} msg] $msg
|
||||
} {1 {bad option "-badopt": must be -blocking, -buffering, -buffersize, -eofchar, -translation, or a channel type specific option}}
|
||||
|
||||
test email-1.4.4 {fconfigure email} {
|
||||
list [catch {
|
||||
fconfigure $eChannel -address something
|
||||
} msg] $msg
|
||||
} {1 {can't set address after email channel is opened}}
|
||||
|
||||
test email-1.4.5 {fconfigure email} {
|
||||
list [catch {
|
||||
fconfigure $eChannel -identifier 999
|
||||
} msg] $msg
|
||||
} {1 {can't set identifier after email channel is opened}}
|
||||
|
||||
|
||||
test email-1.4.6 {fconfigure email} {
|
||||
list [catch {
|
||||
fconfigure $eChannel -blocking no
|
||||
} msg] $msg
|
||||
} {0 {}}
|
||||
|
||||
|
||||
test email-1.4.7 {fconfigure email} {
|
||||
list [catch {
|
||||
fconfigure $eChannel -blocking
|
||||
} msg] $msg
|
||||
} {0 0}
|
||||
|
||||
test email-1.4.8 {fconfigure email} {
|
||||
list [catch {
|
||||
fconfigure $eChannel -peek yes
|
||||
} msg] $msg
|
||||
} {0 {}}
|
||||
|
||||
test email-1.4.9 {fconfigure email} {
|
||||
list [catch {
|
||||
fconfigure $eChannel -peek
|
||||
} msg] $msg
|
||||
} {0 1}
|
||||
|
||||
test email-1.4.10 {fconfigure email} {
|
||||
list [catch {
|
||||
fconfigure $eChannel -peek wrong
|
||||
} msg] $msg
|
||||
} {1 {expected boolean value but got "wrong"}}
|
||||
|
||||
|
||||
test email-1.4.11 {fconfigure email} {
|
||||
list [catch {
|
||||
fconfigure $eChannel -peek 0
|
||||
} msg] $msg
|
||||
} {0 {}}
|
||||
|
||||
test email-1.4.12 {fconfigure email} {
|
||||
list [catch {
|
||||
fconfigure $eChannel -buffering no
|
||||
} msg] $msg
|
||||
} {0 {}}
|
||||
|
||||
|
||||
#
|
||||
# Test send/receive
|
||||
#
|
||||
|
||||
test udp-1.5.1 {send email} {
|
||||
list [catch {
|
||||
puts -nonewline $eChannel "Test1\n"
|
||||
} msg] $msg
|
||||
} {0 {}}
|
||||
|
||||
|
||||
|
||||
proc SetTo1 {} {
|
||||
global flag
|
||||
set flag 1
|
||||
}
|
||||
|
||||
set flag 0
|
||||
|
||||
proc SetTo2 {} {
|
||||
global flag
|
||||
set flag 2
|
||||
}
|
||||
|
||||
|
||||
test email-1.5.2 {fileevent writeable email} {
|
||||
list [catch {
|
||||
fileevent $eChannel writable SetTo2
|
||||
vwait flag
|
||||
set flag
|
||||
} msg] $msg
|
||||
} {0 2}
|
||||
|
||||
# Try out the peek option.
|
||||
|
||||
test email-1.5.3 {peek & fileevent readable email} {
|
||||
list [catch {
|
||||
fconfigure $eChannel -peek yes
|
||||
fileevent $eChannel writable {}
|
||||
fileevent $eChannel readable SetTo1
|
||||
|
||||
# wait for the first message to arrive
|
||||
|
||||
while {$flag != 1} {
|
||||
vwait flag
|
||||
}
|
||||
set x [list $flag [read $eChannel] [read $eChannel]]
|
||||
} msg] $msg
|
||||
} [list 0 [list 1 "Test1\n" "Test1\n"]]
|
||||
|
||||
# Read the two messages that were sent after resetting the peek option.
|
||||
|
||||
test email-1.5.4 {peek & fileevent & readable email} {
|
||||
list [catch {
|
||||
puts -nonewline $eChannel "Test2\n"
|
||||
fconfigure $eChannel -peek no
|
||||
set flag 0
|
||||
set x [list [read $eChannel]]
|
||||
|
||||
# wait for the second message to arrive
|
||||
|
||||
while {$flag != 1} {
|
||||
vwait flag
|
||||
}
|
||||
set x [lappend x [read $eChannel]]
|
||||
} msg] $msg
|
||||
} [list 0 [list "Test1\n" "Test2\n"]]
|
||||
|
||||
|
||||
test email-1.5.5 {close email} {
|
||||
list [catch {
|
||||
close $eChannel
|
||||
} msg] $msg
|
||||
} {0 {}}
|
||||
|
||||
|
||||
test email-1.5.6 {close email} {
|
||||
list [catch {
|
||||
close $eChannel
|
||||
} msg] $msg
|
||||
} {1 {can not find channel named "email0"}}
|
||||
|
||||
|
||||
test email-1.5.7 {test send/receive email} {
|
||||
list [catch {
|
||||
set x "0123456789abcdef"
|
||||
set y "qqwertyuiopasdfg"
|
||||
for {set i 0} {$i < 6} {set i [expr $i + 1]} {
|
||||
set x $x$x
|
||||
set y $y$y
|
||||
}
|
||||
|
||||
set eChannel [dp_connect email -address $myEmailAddress -identifier 100]
|
||||
fconfigure $eChannel -buffering none
|
||||
|
||||
puts -nonewline $eChannel $x
|
||||
puts -nonewline $eChannel $y
|
||||
|
||||
set flag 0
|
||||
|
||||
fileevent $eChannel readable SetTo1
|
||||
|
||||
vwait flag
|
||||
|
||||
set readX [read $eChannel 1024]
|
||||
|
||||
set flag 0
|
||||
vwait flag
|
||||
|
||||
set readY [read $eChannel 1024]
|
||||
|
||||
close $eChannel
|
||||
|
||||
|
||||
if {([string compare $x$y $readX$readY] == 0)||
|
||||
([string compare $x$y $readY$readX] == 0)} {
|
||||
set rez ok
|
||||
} else {
|
||||
set rez failed
|
||||
}
|
||||
|
||||
set rez
|
||||
|
||||
} msg] $msg
|
||||
} {0 ok}
|
||||
|
||||
|
||||
# The following close brace matches the line above:
|
||||
# if {$eChannel != ""}
|
||||
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
164
tcl-dp/tests/identity.test
Normal file
164
tcl-dp/tests/identity.test
Normal file
@@ -0,0 +1,164 @@
|
||||
# identity.test
|
||||
#
|
||||
# This file tests the correct functioning of the standalone
|
||||
# identity filer.
|
||||
#
|
||||
|
||||
# For unix systems: if this test fails, delete all files of the
|
||||
# form ~/.email*, and check the status of your ~/.forward file.
|
||||
|
||||
# The user should define here his/her email address as the system defines it.
|
||||
# This version will work only at the CS Department of Cornell University.
|
||||
|
||||
if {[string compare test [info procs test]] == 1} then {source ../tests/defs}
|
||||
|
||||
|
||||
# set VERBOSE 1
|
||||
|
||||
|
||||
test identity-1.1.1 {dp_connect command} {
|
||||
list [catch {
|
||||
dp_connect identity -bar
|
||||
} msg] $msg
|
||||
} {1 {unknown option "-bar", must be -channel}}
|
||||
|
||||
|
||||
test identity-1.1.2 {dp_connect command} {
|
||||
list [catch {
|
||||
dp_connect identity -bar foo
|
||||
} msg] $msg
|
||||
} {1 {unknown option "-bar", must be -channel}}
|
||||
|
||||
#
|
||||
# Test argument missing checks.
|
||||
#
|
||||
|
||||
test identity-1.2.1 {dp_connect command} {
|
||||
list [catch {
|
||||
dp_connect identity -channel
|
||||
} msg] $msg
|
||||
} {1 {option value missing for -channel}}
|
||||
|
||||
test identity-1.2.2 {dp_connect command} {
|
||||
list [catch {
|
||||
dp_connect identity
|
||||
} msg] $msg
|
||||
} {1 {-channel must be defined for an identity channel}}
|
||||
|
||||
test identity-1.2.3 {dp_connect command} {
|
||||
list [catch {
|
||||
dp_connect identity -channel wrong_channel
|
||||
} msg] $msg
|
||||
} {1 {can not find channel named "wrong_channel"}}
|
||||
|
||||
#
|
||||
# Test functioning by copying data from a file.
|
||||
#
|
||||
|
||||
test identity-1.2.4 {dp_connect command} {
|
||||
list [catch {
|
||||
set x "01234567890123456789012345678901"
|
||||
|
||||
for {set i 0} {[expr $i < 10]} {set i [expr $i + 1]} {
|
||||
set x $x$x
|
||||
}
|
||||
|
||||
set f [open ___tmp {WRONLY CREAT}]
|
||||
puts -nonewline $f $x
|
||||
close $f
|
||||
|
||||
set f [open ___tmp {RDONLY}]
|
||||
|
||||
set idChan [dp_connect identity -channel $f]
|
||||
|
||||
} msg] $msg
|
||||
} {0 idfilter0}
|
||||
|
||||
|
||||
if {$idChan != ""} {
|
||||
|
||||
test identity-1.3.2 {fconfigure command} {
|
||||
list [catch {
|
||||
fconfigure $idChan -translation binary
|
||||
fconfigure $idChan
|
||||
} msg] $msg
|
||||
} [list 0 [list -blocking 1 -buffering full -buffersize 4096 -eofchar {{} {}} -translation {lf lf} -channel $f -peek 0]]
|
||||
|
||||
|
||||
test identity-1.3.3 {fconfigure command} {
|
||||
list [catch {
|
||||
fconfigure $idChan -badoption
|
||||
} msg] $msg
|
||||
} {1 {bad option "-badoption": must be -blocking, -buffering, -buffersize, -eofchar, -translation, or a channel type specific option}}
|
||||
|
||||
test identity-1.3.4 {fconfigure command} {
|
||||
list [catch {
|
||||
fconfigure $idChan -channel
|
||||
} msg] $msg
|
||||
} [list 0 [list $f]]
|
||||
|
||||
test identity-1.3.5 {fconfigure command} {
|
||||
list [catch {
|
||||
fconfigure $idChan -channel something
|
||||
} msg] $msg
|
||||
} {1 {can't set channel after identity channel is opened}}
|
||||
|
||||
|
||||
test identity-1.3.6 {fconfigure command} {
|
||||
list [catch {
|
||||
fconfigure $idChan -peek
|
||||
} msg] $msg
|
||||
} {0 0}
|
||||
|
||||
test identity-1.3.7 {fconfigure command} {
|
||||
list [catch {
|
||||
fconfigure $idChan -peek badvalue
|
||||
} msg] $msg
|
||||
} {1 {expected boolean value but got "badvalue"}}
|
||||
|
||||
test identity-1.3.8 {fconfigure command} {
|
||||
list [catch {
|
||||
fconfigure $idChan -blocking yes
|
||||
} msg] $msg
|
||||
} {0 {}}
|
||||
|
||||
test identity-1.3.9 {dp_copy command} {
|
||||
list [catch {
|
||||
set g [open ___out {WRONLY CREAT}]
|
||||
dp_copy $idChan $g
|
||||
close $f
|
||||
close $g
|
||||
set g [open ___out {RDONLY}]
|
||||
set y [read $g 100000]
|
||||
close $g
|
||||
file delete ___out
|
||||
if {[expr [string compare $x $y] == 0]} {
|
||||
set rez ok
|
||||
} else {
|
||||
set rez failed
|
||||
}
|
||||
} msg] $msg
|
||||
} {0 ok}
|
||||
|
||||
|
||||
test identity-1.3.10 {close identity filter} {
|
||||
list [catch {
|
||||
close $idChan
|
||||
} msg] $msg
|
||||
} {0 {}}
|
||||
|
||||
|
||||
# The following brace matches the line below:
|
||||
# if {$idChan != ""}
|
||||
|
||||
}
|
||||
|
||||
test identity-1.4.1 {cleanup} {
|
||||
list [catch {
|
||||
file delete ___tmp
|
||||
file delete ___out
|
||||
} msg] $msg
|
||||
} {0 {}}
|
||||
|
||||
|
||||
|
||||
254
tcl-dp/tests/ipm.test
Normal file
254
tcl-dp/tests/ipm.test
Normal file
@@ -0,0 +1,254 @@
|
||||
# ipm.test --
|
||||
#
|
||||
# Test the IP multicasting protocol
|
||||
#
|
||||
|
||||
if {[string compare test [info procs test]] == 1} then {source ../tests/defs}
|
||||
|
||||
# UNIX only----------------------------------------
|
||||
# See if this system even HAS IP multicast
|
||||
#
|
||||
if {[catch {dp_connect ipm} msg]} {
|
||||
if {[string match [string range $msg 0 7] "IP multi"]} {
|
||||
puts stdout "*** " nonewline
|
||||
puts stdout $msg
|
||||
set ipm 0
|
||||
return
|
||||
}
|
||||
}
|
||||
set ipm 1
|
||||
|
||||
test ipm-1.0.0 {dp_connect command} {
|
||||
list [catch {
|
||||
dp_connect ipm -bar
|
||||
} msg] $msg
|
||||
} {1 {unknown option "-bar", must be -group, -myport or -ttl}}
|
||||
|
||||
test ipm-1.0.1 {dp_connect command} {
|
||||
list [catch {
|
||||
dp_connect ipm -bar foo
|
||||
} msg] $msg
|
||||
} {1 {unknown option "-bar", must be -group, -myport or -ttl}}
|
||||
|
||||
test ipm-1.1.0 {dp_connect command} {
|
||||
list [catch {
|
||||
dp_connect ipm -myport
|
||||
} msg] $msg
|
||||
} {1 {value for "-myport" missing}}
|
||||
|
||||
test ipm-1.1.1 {dp_connect command} {
|
||||
list [catch {
|
||||
dp_connect ipm
|
||||
} msg] $msg
|
||||
} {1 {option -group must be specified}}
|
||||
|
||||
test ipm-1.1.2 {dp_connect command} {
|
||||
list [catch {
|
||||
dp_connect ipm -group localhost
|
||||
} msg] $msg
|
||||
} {1 {option -myport must be specified}}
|
||||
|
||||
test ipm-1.2.0 {dp_connect command} {
|
||||
list [catch {
|
||||
dp_connect ipm -myport badport
|
||||
} msg] $msg
|
||||
} {1 {expected integer but got "badport"}}
|
||||
|
||||
test ipm-1.2.1 {dp_connect command} {
|
||||
list [catch {
|
||||
dp_connect ipm -myport -1234
|
||||
} msg] $msg
|
||||
} {1 {expected non-negative integer but got "-1234"}}
|
||||
|
||||
test ipm-1.2.2 {dp_connect command} {
|
||||
list [catch {
|
||||
dp_connect ipm -ttl badttl
|
||||
} msg] $msg
|
||||
} {1 {expected integer but got "badttl"}}
|
||||
|
||||
test ipm-1.2.3 {dp_connect command} {
|
||||
list [catch {
|
||||
set id [dp_connect ipm -group 224.0.0.1 -myport 47217 -ttl 3]
|
||||
string range $id 0 2
|
||||
} msg] $msg
|
||||
} {0 ipm}
|
||||
|
||||
#
|
||||
# Our HP-UX machine passes the IPM check in ./configure but
|
||||
# does not actually have IPM in the kernel. This is a last
|
||||
# resort check to catch this bug.
|
||||
# Some systems have the IPM header definitions, but aren't
|
||||
# actually running a multicast kernel. You can see if your
|
||||
# system supports multicast by using "ifconfig" to see
|
||||
# if MULTICAST is one of the interface flags.
|
||||
#
|
||||
|
||||
if {[catch {close $id}]} {
|
||||
puts ""
|
||||
puts ""
|
||||
puts stdout "*** IPM does not seem to work on this system. Aborting test..."
|
||||
puts ""
|
||||
puts ""
|
||||
set ipm 0
|
||||
return
|
||||
}
|
||||
|
||||
test ipm-2.1 {Opening port} {
|
||||
list [catch {
|
||||
set csock [dp_connect ipm -group 224.76.0.1 -myport 47215 -ttl 3]
|
||||
string range $csock 0 2
|
||||
} msg] $msg
|
||||
} {0 ipm}
|
||||
|
||||
test ipm-2.2 {loop back} {
|
||||
list [catch {
|
||||
puts $csock hello1
|
||||
gets $csock
|
||||
} msg] $msg
|
||||
} {0 hello1}
|
||||
|
||||
catch {close $csock}
|
||||
|
||||
#
|
||||
# fconfigure tests
|
||||
#
|
||||
set sock [dp_connect ipm -group 224.76.0.1 -myport 47217]
|
||||
|
||||
test ipm-2.6.1 "fconfigure ipm" {
|
||||
list [catch {
|
||||
fconfigure $sock
|
||||
} msg] $msg
|
||||
} {0 {-blocking 1 -buffering none -buffersize 4096 -eofchar {{} {}} -translation {lf lf} -recvBuffer 8192 -reuseAddr 1 -sendBuffer 8192 -loopback 1 -group 224.76.0.1 -myport 47217}}
|
||||
|
||||
test ipm-2.6.2 "fconfigure ipm" {
|
||||
list [catch {
|
||||
fconfigure $sock -blocking 0
|
||||
} msg] $msg
|
||||
} {0 {}}
|
||||
|
||||
test ipm-2.6.3 "fconfigure ipm" {
|
||||
list [catch {
|
||||
fconfigure $sock -blocking
|
||||
} msg] $msg
|
||||
} {0 0}
|
||||
|
||||
test ipm-2.6.4 "fconfigure ipm" {
|
||||
list [catch {
|
||||
fconfigure $sock -sendBuffer 4096
|
||||
} msg] $msg
|
||||
} {0 {}}
|
||||
|
||||
test ipm-2.6.5 "fconfigure ipm" {
|
||||
list [catch {
|
||||
fconfigure $sock -sendBuffer
|
||||
} msg] $msg
|
||||
} {0 4096}
|
||||
|
||||
test ipm-2.6.6 "fconfigure ipm" {
|
||||
list [catch {
|
||||
fconfigure $sock -sendBuffer -1
|
||||
} msg] $msg
|
||||
} {1 {Buffer size must be > 0}}
|
||||
|
||||
test ipm-2.6.7 "fconfigure ipm" {
|
||||
list [catch {
|
||||
fconfigure $sock -sendBuffer foo
|
||||
} msg] $msg
|
||||
} {1 {expected integer but got "foo"}}
|
||||
|
||||
test ipm-2.6.8 "fconfigure ipm" {
|
||||
list [catch {
|
||||
fconfigure $sock -recvBuffer 4096
|
||||
} msg] $msg
|
||||
} {0 {}}
|
||||
|
||||
test ipm-2.6.9 "fconfigure ipm" {
|
||||
list [catch {
|
||||
fconfigure $sock -recvBuffer
|
||||
} msg] $msg
|
||||
} {0 4096}
|
||||
|
||||
test ipm-2.6.10 "fconfigure ipm" {
|
||||
list [catch {
|
||||
fconfigure $sock -recvBuffer -1
|
||||
} msg] $msg
|
||||
} {1 {Buffer size must be > 0}}
|
||||
|
||||
test ipm-2.6.11 "fconfigure ipm" {
|
||||
list [catch {
|
||||
fconfigure $sock -recvBuffer foo
|
||||
} msg] $msg
|
||||
} {1 {expected integer but got "foo"}}
|
||||
|
||||
|
||||
test ipm-2.6.12.0 "fconfigure ipm" {
|
||||
list [catch {
|
||||
fconfigure $sock -reuseAddr foo
|
||||
} msg] $msg
|
||||
} {1 {expected boolean value but got "foo"}}
|
||||
|
||||
test ipm-2.6.12.1 "fconfigure ipm" {
|
||||
list [catch {
|
||||
fconfigure $sock -reuseAddr 0
|
||||
} msg] $msg
|
||||
} {0 {}}
|
||||
|
||||
test ipm-2.6.12.2 "fconfigure ipm" {
|
||||
list [catch {
|
||||
fconfigure $sock -reuseAddr
|
||||
} msg] $msg
|
||||
} {0 0}
|
||||
|
||||
test ipm-2.6.12.3 "fconfigure ipm" {
|
||||
list [catch {
|
||||
fconfigure $sock -reuseAddr 1
|
||||
} msg] $msg
|
||||
} {0 {}}
|
||||
|
||||
test ipm-2.6.12.4 "fconfigure ipm" {
|
||||
list [catch {
|
||||
fconfigure $sock -reuseAddr
|
||||
} msg] $msg
|
||||
} {0 1}
|
||||
|
||||
test ipm-2.6.12.5 "fconfigure ipm" {
|
||||
list [catch {
|
||||
fconfigure $sock -loopback
|
||||
} msg] $msg
|
||||
} {0 1}
|
||||
|
||||
if {$win == 1} {
|
||||
|
||||
test ipm-2.6.12.6 "fconfigure ipm" {
|
||||
list [catch {
|
||||
fconfigure $sock -loopback 0
|
||||
} msg] $msg
|
||||
} {1 {Loopback may not be turned off in Windows.}}
|
||||
|
||||
} else {
|
||||
|
||||
test ipm-2.6.12.7 "fconfigure ipm" {
|
||||
list [catch {
|
||||
fconfigure $sock -loopback 0
|
||||
} msg] $msg
|
||||
} {0 {}}
|
||||
|
||||
}
|
||||
|
||||
test ipm-2.6.12.8 "fconfigure ipm" {
|
||||
list [catch {
|
||||
fconfigure $sock -myport
|
||||
} msg] $msg
|
||||
} {0 47217}
|
||||
|
||||
test ipm-2.6.12.9 "fconfigure ipm" {
|
||||
list [catch {
|
||||
fconfigure $sock -myport 1700
|
||||
} msg] $msg
|
||||
} {1 {Port may not be changed after creation.}}
|
||||
|
||||
catch {close $sock}
|
||||
|
||||
|
||||
|
||||
|
||||
49
tcl-dp/tests/make-server
Normal file
49
tcl-dp/tests/make-server
Normal file
@@ -0,0 +1,49 @@
|
||||
#
|
||||
# When this file is sourced, a server process is automatically
|
||||
# started that can be used for for testing purposes. If the
|
||||
# server is already running (i.e., some other test sources this file)
|
||||
# then no new server is started.
|
||||
#
|
||||
# The following global variables are defined as a side effect of
|
||||
# sourcing this file:
|
||||
#
|
||||
# hostname -- the name of the host on which the server is running
|
||||
# S_PORT -- the port of the server
|
||||
|
||||
#
|
||||
# Check to see if we haven't sourced already
|
||||
#
|
||||
if {![info exists S_PORT]} {
|
||||
|
||||
#
|
||||
# Determine a port number
|
||||
#
|
||||
set S_PORT 8259
|
||||
set hostname localhost
|
||||
|
||||
#
|
||||
# Setup: Start a server as another process, and use it to connect.
|
||||
#
|
||||
set cmd [info nameofexecutable]
|
||||
puts stdout "Executing \"$cmd server $win $S_PORT\""
|
||||
set serv_pid [exec $cmd server $win $S_PORT &]
|
||||
|
||||
#
|
||||
# This loop keeps trying to connect until it succeeds.
|
||||
# Important since the exec may take a while on some machines...
|
||||
#
|
||||
|
||||
after 2000
|
||||
set itry 0
|
||||
while {[catch "dp_MakeRPCClient $hostname $S_PORT" rhost]} {
|
||||
puts stdout "Trying to connect to server..."
|
||||
incr itry
|
||||
if { $itry > 5 } {
|
||||
puts stdout "Unable to connect to server"
|
||||
break
|
||||
}
|
||||
after 2000
|
||||
}
|
||||
catch {close $rhost}
|
||||
}
|
||||
|
||||
95
tcl-dp/tests/netinfo.test
Normal file
95
tcl-dp/tests/netinfo.test
Normal file
@@ -0,0 +1,95 @@
|
||||
# netinfo.test
|
||||
#
|
||||
# This file tests the dp_netinfo command
|
||||
#
|
||||
|
||||
if {[string compare test [info procs test]] == 1} then {source ../tests/defs}
|
||||
|
||||
test netinfo-noargs {dp_netinfo command} {
|
||||
list [catch {
|
||||
dp_netinfo
|
||||
} msg] $msg
|
||||
} {1 {wrong # args: should be "dp_netinfo option arg"}}
|
||||
|
||||
test netinfo-onearg {dp_netinfo command} {
|
||||
list [catch {
|
||||
dp_netinfo -foo
|
||||
} msg] $msg
|
||||
} {1 {wrong # args: should be "dp_netinfo option arg"}}
|
||||
|
||||
test netinfo-toomanyargs {dp_netinfo command} {
|
||||
list [catch {
|
||||
dp_netinfo one two three
|
||||
} msg] $msg
|
||||
} {1 {wrong # args: should be "dp_netinfo option arg"}}
|
||||
|
||||
#
|
||||
# This test may not succeed everywhere.
|
||||
#
|
||||
test netinfo-localhost {dp_netinfo command} {
|
||||
list [catch {
|
||||
dp_netinfo -address 127.0.0.1
|
||||
} msg] $msg
|
||||
} {0 localhost}
|
||||
|
||||
test netinfo-localhost {dp_netinfo command} {
|
||||
list [catch {
|
||||
set host [dp_netinfo -address 128.84.218.191]
|
||||
string tolower $host
|
||||
} msg] $msg
|
||||
} {0 hercules.cs.cornell.edu}
|
||||
|
||||
test netinfo-unknownoption {dp_netinfo command} {
|
||||
list [catch {
|
||||
dp_netinfo -option arg
|
||||
} msg] $msg
|
||||
} {1 {dp_netinfo: unknown option "-option"}}
|
||||
|
||||
test netinfo-unknownip {dp_netinfo command} {
|
||||
list [catch {
|
||||
dp_netinfo -address 255.255.255.255
|
||||
} msg] $msg
|
||||
} {1 {dp_netinfo -address unknown host "255.255.255.255"}}
|
||||
|
||||
test netinfo-unknownhost {dp_netinfo command} {
|
||||
list [catch {
|
||||
dp_netinfo -address .com
|
||||
} msg] $msg
|
||||
} {1 {dp_netinfo -address unknown host ".com"}}
|
||||
|
||||
#
|
||||
# This test will fail if there is a service at -1.
|
||||
# This test may take a few seconds.
|
||||
#
|
||||
test netinfo-unknownserviceport {dp_netinfo command} {
|
||||
list [catch {
|
||||
dp_netinfo -service -1
|
||||
} msg] $msg
|
||||
} {1 {dp_netinfo -service unknown service/port# "-1"}}
|
||||
|
||||
#
|
||||
# This test may take a few seconds.
|
||||
#
|
||||
test netinfo-unknownservicename {dp_netinfo command} {
|
||||
list [catch {
|
||||
dp_netinfo -service
|
||||
} msg] $msg
|
||||
} {1 {wrong # args: should be "dp_netinfo option arg"}}
|
||||
|
||||
test netinfo-num2name {dp_netinfo command} {
|
||||
list [catch {
|
||||
lindex [dp_netinfo -service 21] 0
|
||||
} msg] $msg
|
||||
} {0 ftp}
|
||||
|
||||
test netinfo-name2num {dp_netinfo command} {
|
||||
list [catch {
|
||||
lindex [dp_netinfo -service ftp] 1
|
||||
} msg] $msg
|
||||
} {0 21}
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
249
tcl-dp/tests/plugin.test
Normal file
249
tcl-dp/tests/plugin.test
Normal file
@@ -0,0 +1,249 @@
|
||||
# plugin.test
|
||||
#
|
||||
# This file tests the correct functioning of the plug-in filters.
|
||||
#
|
||||
|
||||
if {[string compare test [info procs test]] == 1} then {source ../tests/defs}
|
||||
|
||||
|
||||
# set VERBOSE 1
|
||||
|
||||
|
||||
test plugInFilter-1.1.1 {dp_connect command} {
|
||||
list [catch {
|
||||
dp_connect plugfilter -bar
|
||||
} msg] $msg
|
||||
} {1 {unknown option "-bar", must be -channel}}
|
||||
|
||||
test plugInFilter-1.1.2 {dp_connect command} {
|
||||
list [catch {
|
||||
dp_connect plugfilter -bar foo
|
||||
} msg] $msg
|
||||
} {1 {unknown option "-bar", must be -channel}}
|
||||
|
||||
|
||||
#
|
||||
# Test argument missing checks.
|
||||
#
|
||||
|
||||
test plugInFilter-1.2.1 {dp_connect command} {
|
||||
list [catch {
|
||||
dp_connect plugfilter -channel
|
||||
} msg] $msg
|
||||
} {1 {option value missing for -channel}}
|
||||
|
||||
test plugInFilter-1.2.2 {dp_connect command} {
|
||||
list [catch {
|
||||
dp_connect plugfilter
|
||||
} msg] $msg
|
||||
} {1 {-channel must be defined for a plug-in channel}}
|
||||
|
||||
test plugInFilter-1.2.3 {dp_connect command} {
|
||||
list [catch {
|
||||
dp_connect plugfilter -channel wrong_channel
|
||||
} msg] $msg
|
||||
} {1 {can not find channel named "wrong_channel"}}
|
||||
|
||||
#
|
||||
# Test functioning by copying data from a file.
|
||||
#
|
||||
|
||||
test plugInFilter-1.2.4 {dp_connect command} {
|
||||
list [catch {
|
||||
set x "01234567890123456789012345678901"
|
||||
for {set i 0} {[expr $i < 10]} {incr i} {
|
||||
set x $x$x
|
||||
}
|
||||
set f [open ___tmp {WRONLY CREAT}]
|
||||
puts -nonewline $f $x
|
||||
close $f
|
||||
set f [open ___tmp {RDONLY}]
|
||||
set plugChan [dp_connect plugfilter -channel $f]
|
||||
string range $plugChan 0 9
|
||||
} msg] $msg
|
||||
} {0 plugfilter}
|
||||
|
||||
# Need to use dummy because I can not test the value of plugChan in
|
||||
# line above.
|
||||
|
||||
if {$plugChan != ""} {
|
||||
|
||||
if {$win == 1} {
|
||||
|
||||
test plugInFilter-1.3.2 {fconfigure command} {
|
||||
list [catch {
|
||||
fconfigure $plugChan
|
||||
} msg] $msg
|
||||
} [list 0 [list -blocking 1 -buffering full -buffersize 4096 -eofchar {{} {}} -translation {auto crlf} -channel $f -peek 0 -inset {no internal arguments} -outset {no internal arguments}]]
|
||||
|
||||
} else {
|
||||
|
||||
test plugInFilter-1.3.2 {fconfigure command} {
|
||||
list [catch {
|
||||
fconfigure $plugChan
|
||||
} msg] $msg
|
||||
} [list 0 [list -blocking 1 -buffering full -buffersize 4096 -eofchar {{} {}} -translation {auto lf} -channel $f -peek 0 -inset {no internal arguments} -outset {no internal arguments}]]
|
||||
|
||||
}
|
||||
|
||||
test plugInFilter-1.3.3 {fconfigure command} {
|
||||
list [catch {
|
||||
fconfigure $plugChan -badoption
|
||||
} msg] $msg
|
||||
} {1 {bad option "-badoption": must be -blocking, -buffering, -buffersize, -eofchar, -translation, or a channel type specific option}}
|
||||
|
||||
|
||||
test plugInFilter-1.3.4 {fconfigure command} {
|
||||
list [catch {
|
||||
fconfigure $plugChan -channel
|
||||
} msg] $msg
|
||||
} [list 0 [list $f]]
|
||||
|
||||
test plugInFilter-1.3.5 {fconfigure command} {
|
||||
list [catch {
|
||||
fconfigure $plugChan -channel something
|
||||
} msg] $msg
|
||||
} {1 {can't set channel after plug-in channel is opened}}
|
||||
|
||||
|
||||
test plugInFilter-1.3.6 {fconfigure command} {
|
||||
list [catch {
|
||||
fconfigure $plugChan -peek
|
||||
} msg] $msg
|
||||
} {0 0}
|
||||
|
||||
test plugInFilter-1.3.7 {fconfigure command} {
|
||||
list [catch {
|
||||
fconfigure $plugChan -peek badvalue
|
||||
} msg] $msg
|
||||
} {1 {expected boolean value but got "badvalue"}}
|
||||
|
||||
#
|
||||
# Apparently the wording of the file channel's error strings
|
||||
# changed from 7.6 to 8.0.
|
||||
#
|
||||
if {[string compare [string index $tcl_version 0] "7"]} {
|
||||
|
||||
test plugInFilter-1.3.8 {fconfigure command} {
|
||||
list [catch {
|
||||
fconfigure $plugChan -peek yes
|
||||
} msg] $msg
|
||||
} [list 1 [concat {bad option "-peek": should be one of -blocking, -buffering, -buffersize, -eofchar, or -translation: subordinated channel error in} $f]]
|
||||
|
||||
} else {
|
||||
|
||||
test plugInFilter-1.3.8 {fconfigure command} {
|
||||
list [catch {
|
||||
fconfigure $plugChan -peek yes
|
||||
} msg] $msg
|
||||
} [list 1 [concat {bad option "-peek": should be -blocking, -buffering, -buffersize, -eofchar, -translation, or channel type specific option: subordinated channel error in} $f]]
|
||||
|
||||
}
|
||||
|
||||
test plugInFilter-1.3.9 {fconfigure command} {
|
||||
list [catch {
|
||||
fconfigure $plugChan -inset
|
||||
} msg] $msg
|
||||
} {0 {{no internal arguments}}}
|
||||
|
||||
test plugInFilter-1.3.10 {fconfigure command} {
|
||||
list [catch {
|
||||
fconfigure $plugChan -outset
|
||||
} msg] $msg
|
||||
} {0 {{no internal arguments}}}
|
||||
|
||||
test plugInFilter-1.3.11 {fconfigure command} {
|
||||
list [catch {
|
||||
fconfigure $plugChan -inset anything
|
||||
} msg] $msg
|
||||
} {1 {can't set option anything for input filter}}
|
||||
|
||||
test plugInFilter-1.3.12 {fconfigure command} {
|
||||
list [catch {
|
||||
fconfigure $plugChan -outset anything
|
||||
} msg] $msg
|
||||
} {1 {can't set option anything for output filter}}
|
||||
|
||||
test plugInFilter-1.3.13 {dp_copy command} {
|
||||
list [catch {
|
||||
set f1 [open ___out {WRONLY CREAT}]
|
||||
set plugChan2 [dp_connect plugfilter -channel $f1]
|
||||
dp_copy $plugChan $plugChan2
|
||||
} msg] $msg
|
||||
} {0 32768}
|
||||
|
||||
test plugInFilter-1.3.14 {dp_copy command} {
|
||||
list [catch {
|
||||
close $f
|
||||
close $plugChan
|
||||
close $plugChan2
|
||||
close $f1
|
||||
} msg] $msg
|
||||
} {0 {}}
|
||||
|
||||
test plugInFilter-1.3.15 {dp_copy command} {
|
||||
list [catch {
|
||||
set g [open ___out {RDONLY}]
|
||||
set y [read $g 100000]
|
||||
close $g
|
||||
|
||||
file delete ___out
|
||||
|
||||
if {[expr [string compare $x $y] == 0]} {
|
||||
set rez ok
|
||||
} else {
|
||||
set rez failed
|
||||
}
|
||||
} msg] $msg
|
||||
} {0 ok}
|
||||
|
||||
# The following brace matches the line below:
|
||||
# if {$plugChan != ""}
|
||||
|
||||
}
|
||||
|
||||
test plugInFilter-1.4.1 {dp_connect & dp_copy &dp_close command} {
|
||||
list [catch {
|
||||
set f [open ___tmp {RDONLY}]
|
||||
set plugChan [dp_connect plugfilter -channel $f -infilter plug1to2]
|
||||
set h [open ___out2 {WRONLY CREAT}]
|
||||
dp_copy $plugChan $h
|
||||
close $f
|
||||
close $plugChan
|
||||
close $h
|
||||
} msg] $msg
|
||||
} {0 {}}
|
||||
|
||||
test plugInFilter-1.4.2 {dp_connect & dp_copy &dp_close command} {
|
||||
list [catch {
|
||||
set f [open ___out {WRONLY CREAT}]
|
||||
set plugChan [dp_connect plugfilter -channel $f -outfilter plug2to1]
|
||||
set h [open ___out2 {RDONLY}]
|
||||
dp_copy $h $plugChan
|
||||
close $h
|
||||
close $plugChan
|
||||
close $f
|
||||
} msg] $msg
|
||||
} {0 {}}
|
||||
|
||||
test plugInFilter-1.4.3 {result of 1.4.1. & 1.4.2} {
|
||||
list [catch {
|
||||
set f [open ___out {RDONLY}]
|
||||
set y [read $f 100000]
|
||||
close $f
|
||||
file delete ___out ___tmp ___out2
|
||||
if {[expr [string compare $x $y] == 0]} {
|
||||
set rez ok
|
||||
} else {
|
||||
set rez failed
|
||||
}
|
||||
} msg] $msg
|
||||
} {0 ok}
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
262
tcl-dp/tests/plugin2.test
Normal file
262
tcl-dp/tests/plugin2.test
Normal file
@@ -0,0 +1,262 @@
|
||||
# filters.test
|
||||
#
|
||||
# This file tests the correct functioning of the in-built filter functions.
|
||||
# The code for plug-in channels is assumed to work correctly.
|
||||
#
|
||||
|
||||
if {[string compare test [info procs test]] == 1} then {source ../tests/defs}
|
||||
|
||||
# set VERBOSE 1
|
||||
|
||||
test filters-1.1.1 {create test files and strings} {
|
||||
list [catch {
|
||||
|
||||
set x "abcdefghijklmnopqrstuvxyzABCDEFG"
|
||||
set y "ABCDEFGHIJKLMNOPQRSTUVXYZABCDEFG"
|
||||
|
||||
for {set i 0} {[expr $i < 10]} {incr i} {
|
||||
set x $x$x
|
||||
set y $y$y
|
||||
}
|
||||
|
||||
set f [open ___1 {WRONLY CREAT TRUNC}]
|
||||
puts -nonewline $f $x
|
||||
close $f
|
||||
|
||||
} msg] $msg
|
||||
} {0 {}}
|
||||
|
||||
|
||||
test filters-1.2.1 {xor plugin filter setup} {
|
||||
list [catch {
|
||||
|
||||
set cin [open ___1 {RDONLY}]
|
||||
set xin [dp_connect plugfilter -channel $cin -infilter xor]
|
||||
set xxin [dp_connect plugfilter -channel $xin -infilter xor]
|
||||
|
||||
expr [string match plugfilter* $xin] * [string match plugfilter* $xxin]
|
||||
|
||||
} msg] $msg
|
||||
} {0 1}
|
||||
|
||||
|
||||
test filters-1.2.2 {xor plugin internal parameter setup} {
|
||||
list [catch {
|
||||
|
||||
fconfigure $xin -inset "a random string that is not too short"
|
||||
fconfigure $xin -translation binary
|
||||
fconfigure $xxin -inset "a random string that is not too short"
|
||||
fconfigure $xxin -translation binary
|
||||
|
||||
} msg] $msg
|
||||
} {0 {}}
|
||||
|
||||
test filters-1.2.3 {xor plugin internal parameter setup} {
|
||||
list [catch {
|
||||
|
||||
fconfigure $xin -inset "this will not succeed"
|
||||
|
||||
} msg] $msg
|
||||
} {1 {can't set option this will not succeed for input filter}}
|
||||
|
||||
|
||||
test filters-1.2.4 {xor plugin filters used and checked} {
|
||||
list [catch {
|
||||
|
||||
set x1 [ read $xxin 100000 ]
|
||||
|
||||
close $cin
|
||||
close $xin
|
||||
close $xxin
|
||||
|
||||
string compare $x $x1
|
||||
|
||||
} msg] $msg
|
||||
} {0 0}
|
||||
|
||||
|
||||
test filters-1.3.1 {xor and uuencode composite filter setup} {
|
||||
list [catch {
|
||||
|
||||
set cin [open ___1 {RDONLY}]
|
||||
fconfigure $cin -translation binary
|
||||
set xin [dp_connect plugfilter -channel $cin -infilter xor]
|
||||
fconfigure $xin -translation binary -inset "any string"
|
||||
set xxin [dp_connect plugfilter -channel $xin -infilter uuencode]
|
||||
fconfigure $xxin -translation binary
|
||||
|
||||
expr [string match plugfilter* $xin] *[string match plugfilter* $xxin]
|
||||
|
||||
} msg] $msg
|
||||
} {0 1}
|
||||
|
||||
test filters-1.3.2 {xor and uudecode composite filter setup} {
|
||||
list [catch {
|
||||
|
||||
set cout [open ___1x {WRONLY CREAT TRUNC}]
|
||||
fconfigure $cout -translation binary
|
||||
set xout [dp_connect plugfilter -channel $cout -outfilter xor]
|
||||
fconfigure $xout -translation binary -outset "any string"
|
||||
set xxout [dp_connect plugfilter -channel $xout -outfilter uudecode]
|
||||
fconfigure $xxout -translation binary
|
||||
|
||||
expr [string match plugfilter* $xout] * [string match plugfilter* $xxout]
|
||||
|
||||
} msg] $msg
|
||||
} {0 1}
|
||||
|
||||
test filters-1.3.3 {xor/uuencode and uudecode/xor filters used and checked } {
|
||||
list [catch {
|
||||
|
||||
dp_copy $xxin $xxout
|
||||
|
||||
close $cin
|
||||
close $xin
|
||||
close $xxin
|
||||
close $xxout
|
||||
close $xout
|
||||
close $cout
|
||||
|
||||
set cin [open ___1x {RDONLY}]
|
||||
set rx [read $cin 100000]
|
||||
close $cin
|
||||
|
||||
string compare $rx $x
|
||||
|
||||
} msg] $msg
|
||||
} {0 0}
|
||||
|
||||
test filters-1.4.1 {packon plugin filter setup} {
|
||||
list [catch {
|
||||
|
||||
set cin [open ___1 {RDONLY}]
|
||||
set cout [open ___1x {WRONLY CREAT TRUNC}]
|
||||
|
||||
set xout [dp_connect plugfilter -channel $cout -outfilter packon]
|
||||
|
||||
string match plugfilter* $xout
|
||||
|
||||
} msg] $msg
|
||||
} {0 1}
|
||||
|
||||
test filters-1.4.2 {packon filter used} {
|
||||
list [catch {
|
||||
|
||||
for {set r [read $cin 500]} {[string length $r] != 0} {set r [read $cin 500]} {
|
||||
puts -nonewline $xout $r
|
||||
flush $xout
|
||||
flush $cout
|
||||
}
|
||||
|
||||
} msg] $msg
|
||||
} {0 {}}
|
||||
|
||||
close $cin
|
||||
close $xout
|
||||
close $cout
|
||||
|
||||
test filters-1.4.3 {packoff filter setup} {
|
||||
list [catch {
|
||||
|
||||
set cin [open ___1x {RDONLY}]
|
||||
set xin [dp_connect packoff -channel $cin]
|
||||
fconfigure $xin -blocking no
|
||||
|
||||
string match packoff* $xin
|
||||
|
||||
} msg] $msg
|
||||
} {0 0}
|
||||
|
||||
|
||||
test filters-1.4.4 {check correct behavior of packon and packoff} {
|
||||
list [catch {
|
||||
|
||||
set xr ""
|
||||
|
||||
for {set r [read $xin 100]} {[expr [string length $r] != 0]} {set r [read $xin 100 ]} {
|
||||
if {[string length $r] <= 100 } {
|
||||
set xr $xr$r
|
||||
} else {
|
||||
error "String length > 100"
|
||||
}
|
||||
}
|
||||
string compare $xr $x
|
||||
} msg] $msg
|
||||
} {0 0}
|
||||
|
||||
close $cin
|
||||
close $xin
|
||||
|
||||
proc MyTclCode {s mode} {
|
||||
|
||||
switch -exact $mode {
|
||||
|
||||
normal -
|
||||
eof -
|
||||
flush {set s [string toupper $s]}
|
||||
close {set s ""}
|
||||
default error
|
||||
|
||||
}
|
||||
|
||||
return $s
|
||||
|
||||
}
|
||||
|
||||
test filters-1.5.1 {tclfilter setup } {
|
||||
list [catch {
|
||||
|
||||
set cin [open ___1 {RDONLY}]
|
||||
set xin [dp_connect plugfilter -channel $cin -infilter tclfilter]
|
||||
string match plugfilter* $xin
|
||||
|
||||
} msg] $msg
|
||||
} {0 1}
|
||||
|
||||
|
||||
test filters-1.5.2 {tclfilter configuration} {
|
||||
list [catch {
|
||||
fconfigure $xin -inset MyTclCode
|
||||
} msg] $msg
|
||||
} {0 {}}
|
||||
|
||||
|
||||
test filters-1.5.3 {tclfilter configuration} {
|
||||
list [catch {
|
||||
fconfigure $xin -inset ThisWillFail
|
||||
} msg] $msg
|
||||
} {1 {can't set option ThisWillFail for input filter}}
|
||||
|
||||
|
||||
test filters-1.5.4 {} {
|
||||
list [catch {
|
||||
|
||||
set yr [read $xin 100000]
|
||||
|
||||
close $cin
|
||||
close $xin
|
||||
|
||||
string compare $yr $y
|
||||
|
||||
} msg] $msg
|
||||
} {0 0}
|
||||
|
||||
|
||||
test filters-1.6.1 {cleanup} {
|
||||
list [catch {
|
||||
|
||||
file delete ___1
|
||||
file delete ___1x
|
||||
|
||||
} msg] $msg
|
||||
} {0 {}}
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
329
tcl-dp/tests/rpc.test
Normal file
329
tcl-dp/tests/rpc.test
Normal file
@@ -0,0 +1,329 @@
|
||||
#########################################
|
||||
#
|
||||
# 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
|
||||
}
|
||||
49
tcl-dp/tests/ser_xmit.test
Normal file
49
tcl-dp/tests/ser_xmit.test
Normal file
@@ -0,0 +1,49 @@
|
||||
# We can't test the serial port send/recv since
|
||||
# there is no way to do it locally.
|
||||
#
|
||||
# You must define a variable "hookedup" that is
|
||||
# set when there is a NULL modem setup on the first
|
||||
# serial port of each machine or change the dp_connect
|
||||
# line below to the correct port.
|
||||
#
|
||||
# You must also define a variable "send" or
|
||||
# "recv" in the two interpreters.
|
||||
#
|
||||
# Test send/receive
|
||||
#
|
||||
|
||||
if {[info exists hookedup] == 1} {
|
||||
|
||||
if {[string compare test [info procs test]] == 1} then {source ../tests/defs}
|
||||
|
||||
set sock1 [dp_connect serial -device serial1]
|
||||
|
||||
if {[info exists send] == 1} {
|
||||
puts stdout "We're sending ..."
|
||||
test serialxmit-1.0.0 {send serial} {
|
||||
list [catch {
|
||||
puts $sock1 "Test 1"
|
||||
} msg] $msg
|
||||
} {0 {}}
|
||||
}
|
||||
|
||||
if {[info exists recv] == 1} {
|
||||
puts stdout "We're receiving ..."
|
||||
test serialxmit-1.0.0 {read serial} {
|
||||
list [catch {
|
||||
gets $sock1
|
||||
} msg] $msg
|
||||
} {0 {Test 1}}
|
||||
}
|
||||
|
||||
test serial-1.0.1 {peek serial} {
|
||||
fconfigure $sock1 -blocking 0
|
||||
read $sock1
|
||||
} {}
|
||||
fconfigure $sock1 -blocking 1
|
||||
|
||||
close $sock1
|
||||
|
||||
} else {
|
||||
puts stdout "*** Skipping serial send/recv tests..."
|
||||
}
|
||||
220
tcl-dp/tests/serial.test
Normal file
220
tcl-dp/tests/serial.test
Normal file
@@ -0,0 +1,220 @@
|
||||
# serial.test
|
||||
#
|
||||
# This file tests the serial protocol
|
||||
#
|
||||
|
||||
if {[string compare test [info procs test]] == 1} then {source ../tests/defs}
|
||||
|
||||
|
||||
test serial-1.1.1 {dp_connect command} {
|
||||
list [catch {
|
||||
dp_connect serial -bar
|
||||
} msg] $msg
|
||||
} {1 {Unknown option "-bar", must be -device, -block, or -readonly}}
|
||||
|
||||
test serial-1.1.2 {dp_connect command} {
|
||||
list [catch {
|
||||
dp_connect serial -bar foo
|
||||
} msg] $msg
|
||||
} {1 {Unknown option "-bar", must be -device, -block, or -readonly}}
|
||||
|
||||
#
|
||||
# Test arg missing checks
|
||||
#
|
||||
|
||||
test serial-1.2.1 {dp_connect command} {
|
||||
list [catch {
|
||||
dp_connect serial -device
|
||||
} msg] $msg
|
||||
} {1 {Value for "-device" missing}}
|
||||
|
||||
test serial-1.2.2 {dp_connect command} {
|
||||
list [catch {
|
||||
dp_connect serial -block
|
||||
} msg] $msg
|
||||
} {1 {Value for "-block" missing}}
|
||||
|
||||
#
|
||||
# Test type checking of args
|
||||
#
|
||||
|
||||
test serial-1.3.1 {dp_connect command} {
|
||||
list [catch {
|
||||
dp_connect serial -device foo
|
||||
} msg] $msg
|
||||
} {1 {Unknown device "foo"}}
|
||||
|
||||
test serial-1.3.3 {dp_connect command} {
|
||||
list [catch {
|
||||
dp_connect serial -block foo
|
||||
} msg] $msg
|
||||
} {1 {expected boolean value but got "foo"}}
|
||||
|
||||
set sock1 {}
|
||||
test serial-1.3.4 {dp_connect command} {
|
||||
list [catch {
|
||||
set sock1 [dp_connect serial -device serial1 -readonly true];
|
||||
} msg1] $msg1 [catch {
|
||||
close $sock1
|
||||
} msg2] $msg2
|
||||
} {0 serial0 0 {}}
|
||||
set sock1 {}
|
||||
|
||||
test serial-1.3.5 {dp_connect command} {
|
||||
list [catch {
|
||||
set sock1 [dp_connect serial -device serial1];
|
||||
} msg1] $msg1
|
||||
|
||||
# UNIX only -------------------------------------
|
||||
# Are your serial ports writable by root only???
|
||||
# Use the "-readonly true" flag if so or chmod them.
|
||||
} {0 serial1}
|
||||
|
||||
if {$sock1 == ""} {
|
||||
catch {
|
||||
set sock1 [dp_connect serial -device serial1 -readonly true]
|
||||
}
|
||||
}
|
||||
|
||||
# At this point, sock1 is either the null string or a handle to a serial
|
||||
# socket. Only do remaining tests if we could create the socket.
|
||||
|
||||
if {$sock1 != ""} {
|
||||
|
||||
#
|
||||
# fconfigure tests
|
||||
#
|
||||
|
||||
set trans [fconfigure $sock1 -translation]
|
||||
|
||||
test serial-1.4.1 {fconfigure serial} {
|
||||
list [catch {
|
||||
fconfigure $sock1
|
||||
} msg] $msg
|
||||
} {0 [list -blocking 1 -buffering line -buffersize 4096 -eofchar {{} {}} -translation $trans -charsize 8 -stopbits 1 -baudrate 19200 -parity none -device serial1}]
|
||||
|
||||
test serial-1.4.2 {fconfigure serial} {
|
||||
list [catch {
|
||||
fconfigure $sock1 -badopt
|
||||
} msg] $msg
|
||||
} {1 {bad option "-badopt": must be -blocking, -buffering, -buffersize, -eofchar, -translation, or a channel type specific option}}
|
||||
|
||||
test serial-1.4.3 {fconfigure serial} {
|
||||
list [catch {
|
||||
fconfigure $sock1 -blocking 0
|
||||
} msg] $msg
|
||||
} {0 {}}
|
||||
|
||||
test serial-1.4.4 {fconfigure serial} {
|
||||
list [catch {
|
||||
fconfigure $sock1 -blocking
|
||||
} msg] $msg
|
||||
} {0 0}
|
||||
|
||||
test serial-1.4.5.1 {fconfigure serial} {
|
||||
list [catch {
|
||||
fconfigure $sock1 -charsize
|
||||
} msg] $msg
|
||||
} {0 8}
|
||||
|
||||
test serial-1.4.5.2 {fconfigure serial} {
|
||||
list [catch {
|
||||
fconfigure $sock1 -charsize foo
|
||||
} msg] $msg
|
||||
} {1 {expected integer but got "foo"}}
|
||||
|
||||
test serial-1.4.5.3 {fconfigure serial} {
|
||||
list [catch {
|
||||
fconfigure $sock1 -charsize 7
|
||||
} msg1] $msg1 [catch {
|
||||
fconfigure $sock1 -charsize
|
||||
} msg2] $msg2
|
||||
} {0 {} 0 7}
|
||||
|
||||
test serial-1.4.6.1 {fconfigure serial} {
|
||||
list [catch {
|
||||
fconfigure $sock1 -stopbits 2
|
||||
} msg1] $msg1 [catch {
|
||||
fconfigure $sock1 -stopbits
|
||||
} msg2] $msg2
|
||||
} {0 {} 0 2}
|
||||
|
||||
test serial-1.4.6.2 {fconfigure serial} {
|
||||
list [catch {
|
||||
fconfigure $sock1 -stopbits foo
|
||||
} msg1] $msg1
|
||||
} {1 {expected integer but got "foo"}}
|
||||
|
||||
test serial-1.4.7.1 {fconfigure serial} {
|
||||
list [catch {
|
||||
fconfigure $sock1 -baudrate
|
||||
} msg1] $msg1
|
||||
} {0 19200}
|
||||
|
||||
test serial-1.4.7.2 {fconfigure serial} {
|
||||
list [catch {
|
||||
fconfigure $sock1 -baudrate foo
|
||||
} msg1] $msg1
|
||||
} {1 {expected integer but got "foo"}}
|
||||
|
||||
test serial-1.4.7.3 {fconfigure serial} {
|
||||
list [catch {
|
||||
fconfigure $sock1 -baudrate 34567
|
||||
} msg1] $msg1
|
||||
} {1 {}}
|
||||
|
||||
test serial-1.4.7.4 {fconfigure serial} {
|
||||
list [catch {
|
||||
fconfigure $sock1 -baudrate 38400
|
||||
} msg1] $msg1 [catch {
|
||||
fconfigure $sock1 -baudrate
|
||||
} msg2] $msg2
|
||||
} {0 {} 0 38400}
|
||||
|
||||
test serial-1.4.8.1 {fconfigure serial} {
|
||||
list [catch {
|
||||
fconfigure $sock1 -parity foo
|
||||
} msg1] $msg1
|
||||
} {1 {Parity must be "even", "odd" or "none"}}
|
||||
|
||||
test serial-1.4.8.2 {fconfigure serial} {
|
||||
list [catch {
|
||||
fconfigure $sock1 -parity even
|
||||
} msg1] $msg1 [catch {
|
||||
fconfigure $sock1 -parity
|
||||
} msg2] $msg2
|
||||
} {0 {} 0 even}
|
||||
|
||||
test serial-1.4.9 {fconfigure serial} {
|
||||
list [catch {
|
||||
fconfigure $sock1
|
||||
} msg] $msg
|
||||
} {0 [list -blocking 0 -buffering line -buffersize 4096 -eofchar {{} {}} -translation $trans -charsize 7 -stopbits 2 -baudrate 38400 -parity even -device serial1}]
|
||||
|
||||
########################
|
||||
|
||||
#
|
||||
# Shut 'em down
|
||||
#
|
||||
test serial-1.9.0 {close serial socket} {
|
||||
list [catch {
|
||||
close $sock1
|
||||
} msg] $msg
|
||||
} {0 {}}
|
||||
|
||||
test serial-1.9.1 {close serial socket} {
|
||||
list [catch {
|
||||
fconfigure $sock1
|
||||
} msg] $msg
|
||||
} [list 1 "can not find channel named \"$sock1\""]
|
||||
|
||||
|
||||
# The following close brace matches the line above:
|
||||
# if {$sock1 != ""}
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
39
tcl-dp/tests/server
Normal file
39
tcl-dp/tests/server
Normal file
@@ -0,0 +1,39 @@
|
||||
if {[lindex $argv 0] == "1"} {
|
||||
load ../win/dp40.dll
|
||||
} else {
|
||||
load ../unix/libdp40[info sharedlibextension]
|
||||
}
|
||||
|
||||
source ../library/dp_atexit.tcl
|
||||
source ../library/dp_atclose.tcl
|
||||
source ../library/rpc.tcl
|
||||
source ../library/acl.tcl
|
||||
|
||||
set s [dp_MakeRPCServer [lindex $argv 1]]
|
||||
if {[string match tcp* $s]} {
|
||||
|
||||
set outFile stderr
|
||||
proc DebugOn {str} {
|
||||
global outFile
|
||||
traceProc $str "PrintTrace $outFile"
|
||||
}
|
||||
|
||||
proc PrintTrace {f traceId level args} {
|
||||
set fmtstr "%[set level]s"
|
||||
set argstr [format %s $args]
|
||||
if {[string length $argstr] > 60} {
|
||||
set argstr "[string range $argstr 0 60] ..."
|
||||
}
|
||||
set cr [string first "\n" $argstr]
|
||||
if {$cr != -1} {
|
||||
incr cr -1
|
||||
set argstr "[string range $argstr 0 $cr] ..."
|
||||
}
|
||||
puts $f "[format $fmtstr ""] $argstr"
|
||||
}
|
||||
vwait forever
|
||||
|
||||
} else {
|
||||
puts stdout "Error creating test RPC server"
|
||||
}
|
||||
|
||||
266
tcl-dp/tests/tcp.test
Normal file
266
tcl-dp/tests/tcp.test
Normal file
@@ -0,0 +1,266 @@
|
||||
# tcp.test --
|
||||
#
|
||||
# Test the TCP protocol
|
||||
#
|
||||
|
||||
if {[string compare test [info procs test]] == 1} then {source ../tests/defs}
|
||||
|
||||
test tcp-1.1 {dp_connect command} {
|
||||
list [catch {
|
||||
dp_connect tcp -bar
|
||||
} msg] $msg
|
||||
} {1 {unknown option "-bar", must be -async, -host, -myaddr, -myport -port or -server}}
|
||||
|
||||
test tcp-1.2 {dp_connect command} {
|
||||
list [catch {
|
||||
dp_connect tcp -bar foo
|
||||
} msg] $msg
|
||||
} {1 {unknown option "-bar", must be -async, -host, -myaddr, -myport -port or -server}}
|
||||
|
||||
test tcp-1.3 {dp_connect command} {
|
||||
list [catch {
|
||||
dp_connect tcp -port
|
||||
} msg] $msg
|
||||
} {1 {value for "-port" missing}}
|
||||
|
||||
test tcp-1.4 {dp_connect command} {
|
||||
list [catch {
|
||||
dp_connect tcp
|
||||
} msg] $msg
|
||||
} {1 {option -port must be specified for clients}}
|
||||
|
||||
test tcp-1.5 {dp_connect command} {
|
||||
list [catch {
|
||||
dp_connect tcp -port badport
|
||||
} msg] $msg
|
||||
} {1 {expected integer but got "badport"}}
|
||||
|
||||
test tcp-1.6 {dp_connect command} {
|
||||
list [catch {
|
||||
dp_connect tcp -server 1
|
||||
} msg] $msg
|
||||
} {1 {option -myport must be specified for servers}}
|
||||
|
||||
test tcp-1.7 {dp_connect command} {
|
||||
list [catch {
|
||||
dp_connect tcp -server 1 -myport 1234 -async 1
|
||||
} msg] $msg
|
||||
} {1 {option -async is not valid for servers}}
|
||||
|
||||
test tcp-1.8 {dp_connect command} {
|
||||
list [catch {
|
||||
dp_connect tcp -server 1 -myport 1234 -host localhost
|
||||
} msg] $msg
|
||||
} {1 {option -host is not valid for servers}}
|
||||
|
||||
test tcp-1.9 {dp_connect command} {
|
||||
list [catch {
|
||||
dp_connect tcp -server 1 -myport 1234 -port 1234
|
||||
} msg] $msg
|
||||
} {1 {option -port is not valid for servers}}
|
||||
|
||||
test tcp-2.0.1 {Opening port with no service.} {
|
||||
list [catch {
|
||||
set csock [dp_connect tcp -host localhost -port 14466]
|
||||
} msg] $msg
|
||||
} {1 {couldn't open socket: connection refused}}
|
||||
|
||||
test tcp-2.1 {dp_accept command} {
|
||||
list [catch {dp_accept} message] $message
|
||||
} {1 {wrong # args: should be "dp_accept channelId"}}
|
||||
|
||||
test tcp-2.2 {dp_accept command} {
|
||||
list [catch {
|
||||
set ssock [dp_connect tcp -server 1 -myport 14467]
|
||||
set csock [dp_connect tcp -host localhost -port 14467]
|
||||
after 500
|
||||
set asock [lindex [dp_accept $ssock] 0]
|
||||
puts $csock hello1
|
||||
set line [gets $asock]
|
||||
} msg] $msg
|
||||
} {0 hello1}
|
||||
|
||||
catch {close $ssock}
|
||||
catch {close $csock}
|
||||
catch {close $asock}
|
||||
|
||||
test tcp-2.3 {Closing of server sockets} {
|
||||
list [catch {
|
||||
set csock [dp_connect tcp -host localhost -port 14470]
|
||||
} msg] $msg
|
||||
} {1 {couldn't open socket: connection refused}}
|
||||
|
||||
catch {close $csock}
|
||||
|
||||
test tcp-2.4 {Closing of client sockets} {
|
||||
set ssock [dp_connect tcp -server 1 -myport 14468]
|
||||
set csock [dp_connect tcp -host localhost -port 14468 -async 1]
|
||||
after 500
|
||||
set asock [lindex [dp_accept $ssock] 0]
|
||||
close $asock
|
||||
after 1000
|
||||
catch {
|
||||
puts $csock hello1
|
||||
} msg
|
||||
regexp {^error writing} $msg
|
||||
} [regexp {^error writing} {error writing "tcp2": broken pipe}]
|
||||
|
||||
catch {close $csock}
|
||||
catch {close $ssock}
|
||||
|
||||
test tcp-2.5 {asynchronous client Tcp socket} {
|
||||
list [catch {
|
||||
set ssock [dp_connect tcp -server 1 -myport 14469]
|
||||
set csock [dp_connect tcp -host localhost -port 14469 -myport 14470 -async 1]
|
||||
after 500
|
||||
set asock [lindex [dp_accept $ssock] 0]
|
||||
puts $csock hello1
|
||||
set line [gets $asock]
|
||||
} msg] $msg
|
||||
} {0 hello1}
|
||||
|
||||
#
|
||||
# fconfigure tests
|
||||
#
|
||||
|
||||
catch {set myIpAddr [dp_netinfo -address [info hostname]]}
|
||||
if {$myIpAddr == 0} {
|
||||
puts stdout "Error determining IP address"
|
||||
}
|
||||
|
||||
test tcp-2.6.1.1 "fconfigure tcp (ssock)" {
|
||||
list [catch {
|
||||
fconfigure $ssock
|
||||
} msg] $msg
|
||||
} [list 0 [list -blocking 1 -buffering none -buffersize 4096 -eofchar {{} {}} -translation {lf lf} -keepAlive 0 -linger 0 -recvBuffer 8192 -reuseAddr 1 -sendBuffer 8192 -myIpAddr $myIpAddr -myport 14469 -destIpAddr 0.0.0.0 -destport 0]]
|
||||
|
||||
test tcp-2.6.1.2 "fconfigure tcp (csock)" {
|
||||
list [catch {
|
||||
fconfigure $csock
|
||||
} msg] $msg
|
||||
} [list 0 [list -blocking 1 -buffering none -buffersize 4096 -eofchar {{} {}} -translation {lf lf} -keepAlive 0 -linger 0 -recvBuffer 8192 -reuseAddr 1 -sendBuffer 8192 -myIpAddr $myIpAddr -myport 14470 -destIpAddr 127.0.0.1 -destport 14469]]
|
||||
|
||||
test tcp-2.6.1.2 "fconfigure tcp (asock)" {
|
||||
list [catch {
|
||||
fconfigure $asock
|
||||
} msg] $msg
|
||||
} [list 0 [list -blocking 1 -buffering none -buffersize 4096 -eofchar {{} {}} -translation {lf lf} -keepAlive 0 -linger 0 -recvBuffer 8192 -reuseAddr 1 -sendBuffer 8192 -myIpAddr $myIpAddr -myport 14469 -destIpAddr 127.0.0.1 -destport 14470]]
|
||||
|
||||
test tcp-2.6 {fconfigure tcp} {
|
||||
|
||||
foreach type "ssock csock asock" {
|
||||
set sock [set $type]
|
||||
|
||||
test tcp-2.6.2 "fconfigure tcp ($type)" {
|
||||
list [catch {
|
||||
fconfigure $sock -blocking 0
|
||||
} msg] $msg
|
||||
} {0 {}}
|
||||
|
||||
test tcp-2.6.3 "fconfigure tcp ($type)" {
|
||||
list [catch {
|
||||
fconfigure $sock -blocking
|
||||
} msg] $msg
|
||||
} {0 0}
|
||||
|
||||
test tcp-2.6.4 "fconfigure tcp ($type)" {
|
||||
list [catch {
|
||||
fconfigure $sock -sendBuffer 4096
|
||||
} msg] $msg
|
||||
} {0 {}}
|
||||
|
||||
test tcp-2.6.5 "fconfigure tcp ($type)" {
|
||||
list [catch {
|
||||
fconfigure $sock -sendBuffer
|
||||
} msg] $msg
|
||||
} {0 4096}
|
||||
|
||||
test tcp-2.6.6 "fconfigure tcp ($type)" {
|
||||
list [catch {
|
||||
fconfigure $sock -sendBuffer -1
|
||||
} msg] $msg
|
||||
} {1 {Buffer size must be > 0}}
|
||||
|
||||
test tcp-2.6.7 "fconfigure tcp ($type)" {
|
||||
list [catch {
|
||||
fconfigure $sock -sendBuffer foo
|
||||
} msg] $msg
|
||||
} {1 {expected integer but got "foo"}}
|
||||
|
||||
test tcp-2.6.8 "fconfigure tcp ($type)" {
|
||||
list [catch {
|
||||
fconfigure $sock -recvBuffer 4096
|
||||
} msg] $msg
|
||||
} {0 {}}
|
||||
|
||||
test tcp-2.6.9 "fconfigure tcp ($type)" {
|
||||
list [catch {
|
||||
fconfigure $sock -recvBuffer
|
||||
} msg] $msg
|
||||
} {0 4096}
|
||||
|
||||
test tcp-2.6.10 "fconfigure tcp ($type)" {
|
||||
list [catch {
|
||||
fconfigure $sock -recvBuffer -1
|
||||
} msg] $msg
|
||||
} {1 {Buffer size must be > 0}}
|
||||
|
||||
test tcp-2.6.11 "fconfigure tcp ($type)" {
|
||||
list [catch {
|
||||
fconfigure $sock -recvBuffer foo
|
||||
} msg] $msg
|
||||
} {1 {expected integer but got "foo"}}
|
||||
|
||||
|
||||
foreach opt {-keepAlive -reuseAddr} {
|
||||
test tcp-2.6.12.0 "fconfigure tcp ($type)" {
|
||||
list [catch {
|
||||
fconfigure $sock $opt foo
|
||||
} msg] $msg
|
||||
} {1 {expected boolean value but got "foo"}}
|
||||
|
||||
test tcp-2.6.12.1 "fconfigure tcp ($type)" {
|
||||
list [catch {
|
||||
fconfigure $sock $opt 0
|
||||
} msg] $msg
|
||||
} {0 {}}
|
||||
|
||||
test tcp-2.6.12.2 "fconfigure tcp ($type)" {
|
||||
list [catch {
|
||||
fconfigure $sock $opt
|
||||
} msg] $msg
|
||||
} {0 0}
|
||||
|
||||
test tcp-2.6.12.3 "fconfigure tcp ($type)" {
|
||||
list [catch {
|
||||
fconfigure $sock $opt 1
|
||||
} msg] $msg
|
||||
} {0 {}}
|
||||
|
||||
test tcp-2.6.12.4 "fconfigure tcp ($type)" {
|
||||
list [catch {
|
||||
fconfigure $sock $opt
|
||||
} msg] $msg
|
||||
} {0 1}
|
||||
}
|
||||
}
|
||||
|
||||
set result_is ok
|
||||
} ok
|
||||
|
||||
catch {close $ssock}
|
||||
catch {close $csock}
|
||||
catch {close $asock}
|
||||
|
||||
# CORNELL ONLY TESTS
|
||||
|
||||
# (ToDo) Connect to a "test server" instead.
|
||||
#
|
||||
test cornell-tcp-3.1 {dp_connect command} {
|
||||
set chan [dp_connect tcp -host www -port 80]
|
||||
|
||||
puts $chan "GET /"
|
||||
flush $chan
|
||||
string range [gets $chan] 0 5
|
||||
} {<!DOCT}
|
||||
|
||||
354
tcl-dp/tests/udp.test
Normal file
354
tcl-dp/tests/udp.test
Normal file
@@ -0,0 +1,354 @@
|
||||
# udp.test
|
||||
#
|
||||
# This file tests the udp protocol
|
||||
#
|
||||
|
||||
if {[string compare test [info procs test]] == 1} then {source ../tests/defs}
|
||||
|
||||
# set VERBOSE 1
|
||||
|
||||
test udp-1.1.1 {dp_connect command} {
|
||||
list [catch {
|
||||
dp_connect udp -bar
|
||||
} msg] $msg
|
||||
} {1 {unknown option "-bar", must be -host, -myaddr, -myport or -port}}
|
||||
|
||||
test udp-1.1.2 {dp_connect command} {
|
||||
list [catch {
|
||||
dp_connect udp -bar foo
|
||||
} msg] $msg
|
||||
} {1 {unknown option "-bar", must be -host, -myaddr, -myport or -port}}
|
||||
|
||||
#
|
||||
# Test arg missing checks
|
||||
#
|
||||
|
||||
test udp-1.2.1 {dp_connect command} {
|
||||
list [catch {
|
||||
dp_connect udp -host
|
||||
} msg] $msg
|
||||
} {1 {value for "-host" missing}}
|
||||
|
||||
test udp-1.2.2 {dp_connect command} {
|
||||
list [catch {
|
||||
dp_connect udp -port
|
||||
} msg] $msg
|
||||
} {1 {value for "-port" missing}}
|
||||
|
||||
test udp-1.2.3 {dp_connect command} {
|
||||
list [catch {
|
||||
dp_connect udp -myaddr
|
||||
} msg] $msg
|
||||
} {1 {value for "-myaddr" missing}}
|
||||
|
||||
test udp-1.2.4 {dp_connect command} {
|
||||
list [catch {
|
||||
dp_connect udp -myport
|
||||
} msg] $msg
|
||||
} {1 {value for "-myport" missing}}
|
||||
|
||||
#
|
||||
# Test type checking of args
|
||||
#
|
||||
|
||||
test udp-1.3.1 {dp_connect command} {
|
||||
list [catch {
|
||||
dp_connect udp -host ""
|
||||
} msg] $msg
|
||||
} {1 {Unknown host ""}}
|
||||
|
||||
# This test must only be run if the client can communicate with
|
||||
# the DNS
|
||||
|
||||
#test udp-1.3.2 {dp_connect command} {
|
||||
# list [catch {
|
||||
# dp_connect udp -host foo
|
||||
# } msg] $msg
|
||||
#} {1 {Unknown host "foo"}}
|
||||
|
||||
test udp-1.3.3 {dp_connect command} {
|
||||
list [catch {
|
||||
dp_connect udp -port foo
|
||||
} msg] $msg
|
||||
} {1 {expected integer but got "foo"}}
|
||||
|
||||
# Only run if we're on a network
|
||||
#test udp-1.3.4 {dp_connect command} {
|
||||
# list [catch {
|
||||
# dp_connect udp -myaddr foo
|
||||
# } msg] $msg
|
||||
#} {1 {Illegal value for -myaddr "foo"}}
|
||||
|
||||
test udp-1.3.5 {dp_connect command} {
|
||||
list [catch {
|
||||
dp_connect udp -myport foo
|
||||
} msg] $msg
|
||||
} {1 {expected integer but got "foo"}}
|
||||
|
||||
set sock1 {}
|
||||
set sock2 {}
|
||||
test udp-1.3.6 {dp_connect command} {
|
||||
catch {
|
||||
set sock1 [dp_connect udp -host localhost -port 19065 -myport 19056];
|
||||
set sock2 [dp_connect udp -host localhost -port 19056 -myport 19065];
|
||||
}
|
||||
} 0
|
||||
|
||||
# At this point, sock1 is either the null string or a handle to a udp
|
||||
# socket. Only do remaining tests if we could create the socket.
|
||||
|
||||
if {$sock1 != ""} {
|
||||
|
||||
#
|
||||
# fconfigure tests
|
||||
#
|
||||
|
||||
test udp-1.4.1 {fconfigure udp} {
|
||||
list [catch {
|
||||
fconfigure $sock1
|
||||
} msg] $msg
|
||||
} {0 {-blocking 1 -buffering none -buffersize 4096 -eofchar {{} {}} -translation {lf lf} -sendBuffer 8192 -recvBuffer 8192 -peek 0 -host 127.0.0.1 -port 19065 -myport 19056}}
|
||||
|
||||
test udp-1.4.2 {fconfigure udp} {
|
||||
list [catch {
|
||||
fconfigure $sock1 -badopt
|
||||
} msg] $msg
|
||||
} {1 {bad option "-badopt": must be -blocking, -buffering, -buffersize, -eofchar, -translation, or a channel type specific option}}
|
||||
|
||||
test udp-1.4.3 {fconfigure udp} {
|
||||
list [catch {
|
||||
fconfigure $sock1 -myport 1000
|
||||
} msg] $msg
|
||||
} {1 {Can't set port after socket is opened}}
|
||||
|
||||
test udp-1.4.3 {fconfigure udp} {
|
||||
list [catch {
|
||||
fconfigure $sock2 -blocking 0
|
||||
} msg] $msg
|
||||
} {0 {}}
|
||||
|
||||
test udp-1.4.4 {fconfigure udp} {
|
||||
list [catch {
|
||||
fconfigure $sock2 -blocking
|
||||
} msg] $msg
|
||||
} {0 0}
|
||||
|
||||
test udp-1.4.5.1 {fconfigure udp} {
|
||||
list [catch {
|
||||
fconfigure $sock1 -sendBuffer 4096
|
||||
} msg] $msg
|
||||
} {0 {}}
|
||||
|
||||
test udp-1.4.5.2 {fconfigure udp} {
|
||||
list [catch {
|
||||
fconfigure $sock1 -sendBuffer
|
||||
} msg] $msg
|
||||
} {0 4096}
|
||||
|
||||
test udp-1.4.5.3 {fconfigure udp} {
|
||||
list [catch {
|
||||
fconfigure $sock1 -sendBuffer -1
|
||||
} msg] $msg
|
||||
} {1 {Buffer size must be > 0}}
|
||||
|
||||
test udp-1.4.5.4 {fconfigure udp} {
|
||||
list [catch {
|
||||
fconfigure $sock1 -sendBuffer foo
|
||||
} msg] $msg
|
||||
} {1 {expected integer but got "foo"}}
|
||||
|
||||
test udp-1.4.6.1 {fconfigure udp} {
|
||||
list [catch {
|
||||
fconfigure $sock1 -recvBuffer 4096
|
||||
} msg] $msg
|
||||
} {0 {}}
|
||||
|
||||
test udp-1.4.6.2 {fconfigure udp} {
|
||||
list [catch {
|
||||
fconfigure $sock1 -recvBuffer
|
||||
} msg] $msg
|
||||
} {0 4096}
|
||||
|
||||
test udp-1.4.6.3 {fconfigure udp} {
|
||||
list [catch {
|
||||
fconfigure $sock1 -recvBuffer -1
|
||||
} msg] $msg
|
||||
} {1 {Buffer size must be > 0}}
|
||||
|
||||
test udp-1.4.6.4 {fconfigure udp} {
|
||||
list [catch {
|
||||
fconfigure $sock1 -recvBuffer foo
|
||||
} msg] $msg
|
||||
} {1 {expected integer but got "foo"}}
|
||||
|
||||
test udp-1.4.7.1 {fconfigure udp} {
|
||||
list [catch {
|
||||
fconfigure $sock1 -peek 1
|
||||
} msg] $msg
|
||||
} {0 {}}
|
||||
|
||||
test udp-1.4.7.2 {fconfigure udp} {
|
||||
list [catch {
|
||||
fconfigure $sock1 -peek
|
||||
} msg] $msg
|
||||
} {0 1}
|
||||
|
||||
test udp-1.4.7.3 {fconfigure udp} {
|
||||
list [catch {
|
||||
fconfigure $sock1 -peek foo
|
||||
} msg] $msg
|
||||
} {1 {expected boolean value but got "foo"}}
|
||||
|
||||
test udp-1.4.7.4 {fconfigure udp} {
|
||||
list [catch {
|
||||
fconfigure $sock1 -peek 0
|
||||
} msg] $msg
|
||||
} {0 {}}
|
||||
|
||||
test udp-1.4.8.1 {fconfigure udp} {
|
||||
list [catch {
|
||||
fconfigure $sock1 -host 127.0.0.1
|
||||
} msg] $msg
|
||||
} {0 {}}
|
||||
|
||||
test udp-1.4.8.2 {fconfigure udp} {
|
||||
list [catch {
|
||||
fconfigure $sock1 -host
|
||||
} msg] $msg
|
||||
} {0 127.0.0.1}
|
||||
|
||||
test udp-1.4.8.3 {fconfigure udp} {
|
||||
list [catch {
|
||||
fconfigure $sock1 -host ftp.cs.cornell.edu
|
||||
} msg1] $msg1 [catch {
|
||||
fconfigure $sock1 -host
|
||||
} msg2] $msg2
|
||||
} {0 {} 0 128.84.154.10}
|
||||
|
||||
test udp-1.4.8.4 {fconfigure udp} {
|
||||
list [catch {
|
||||
fconfigure $sock1 -host localhost
|
||||
} msg1] $msg1 [catch {
|
||||
fconfigure $sock1 -host
|
||||
} msg2] $msg2
|
||||
} {0 {} 0 127.0.0.1}
|
||||
|
||||
test udp-1.4.9.1 {fconfigure udp} {
|
||||
list [catch {
|
||||
fconfigure $sock1 -port 2048
|
||||
} msg1] $msg1
|
||||
} {0 {}}
|
||||
|
||||
test udp-1.4.9.2 {fconfigure udp} {
|
||||
list [catch {
|
||||
fconfigure $sock1 -port
|
||||
} msg1] $msg1
|
||||
} {0 2048}
|
||||
|
||||
test udp-1.4.9.3 {fconfigure udp} {
|
||||
list [catch {
|
||||
fconfigure $sock1 -port -1
|
||||
} msg1] $msg1
|
||||
} {1 {Port number must be > 0}}
|
||||
|
||||
test udp-1.4.9.4 {fconfigure udp} {
|
||||
list [catch {
|
||||
fconfigure $sock1 -port foo
|
||||
} msg1] $msg1
|
||||
} {1 {expected integer but got "foo"}}
|
||||
|
||||
test udp-1.4.9.5 {fconfigure udp} {
|
||||
list [catch {
|
||||
fconfigure $sock1 -port 19065
|
||||
} msg1] $msg1 [catch {
|
||||
fconfigure $sock1 -port
|
||||
} msg2] $msg2
|
||||
} {0 {} 0 19065}
|
||||
|
||||
test udp-1.4.10 {fconfigure udp} {
|
||||
list [catch {
|
||||
fconfigure $sock1 -myport 1
|
||||
} msg1] $msg1 [catch {
|
||||
fconfigure $sock1 -myport
|
||||
} msg2] $msg2
|
||||
} {1 {Can't set port after socket is opened} 0 19056}
|
||||
|
||||
#
|
||||
# Test send/receive
|
||||
#
|
||||
|
||||
test udp-1.5.1 {send udp} {
|
||||
list [catch {
|
||||
puts -nonewline $sock1 "Testing 1 2 3"
|
||||
flush $sock1
|
||||
} msg] $msg
|
||||
} {0 {}}
|
||||
|
||||
test udp-1.5.2 {read udp} {
|
||||
list [catch {
|
||||
read $sock2
|
||||
} msg] $msg
|
||||
} {0 {Testing 1 2 3}}
|
||||
|
||||
#
|
||||
# Try out the peek option. We'll put 2 messages on the wire,
|
||||
# and we should get the same one twice. If so, we clear the
|
||||
# peek and we should get the two messages on the next two
|
||||
# reads.
|
||||
#
|
||||
test udp-1.5.3 {peek udp} {
|
||||
puts -nonewline $sock1 "12345678901"
|
||||
flush $sock1
|
||||
puts -nonewline $sock1 "12345678902"
|
||||
flush $sock1
|
||||
fconfigure $sock2 -peek 1
|
||||
set x [list [read $sock2] [read $sock2]]
|
||||
} {12345678901 12345678901}
|
||||
|
||||
test udp-1.5.4 {send udp} {
|
||||
fconfigure $sock2 -peek 0
|
||||
if {![string compare [lindex $x 1] "12345678901"]} {
|
||||
set x [list [read $sock2] [read $sock2]]
|
||||
} else {
|
||||
set x {12345678901 12345678902}
|
||||
}
|
||||
} {12345678901 12345678902}
|
||||
|
||||
test udp-1.5.5 {dp_from variable} {
|
||||
list [catch {
|
||||
set a $dp_from
|
||||
} msg] $msg
|
||||
} {0 {{127.0.0.1 19056}}}
|
||||
|
||||
#
|
||||
# Shut 'em down
|
||||
#
|
||||
test udp-1.9.0 {close udp socket} {
|
||||
list [catch {
|
||||
close $sock1
|
||||
} msg] $msg
|
||||
} {0 {}}
|
||||
|
||||
test udp-1.9.2 {close udp socket} {
|
||||
list [catch {
|
||||
close $sock2
|
||||
} msg] $msg
|
||||
} {0 {}}
|
||||
|
||||
test udp-1.9.3 {close udp socket} {
|
||||
list [catch {
|
||||
fconfigure $sock2
|
||||
} msg] $msg
|
||||
} [list 1 "can not find channel named \"$sock2\""]
|
||||
|
||||
# The following close brace matches the line above:
|
||||
# if {$sock1 != ""}
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
100
tcl-dp/tests/xmit.test
Normal file
100
tcl-dp/tests/xmit.test
Normal file
@@ -0,0 +1,100 @@
|
||||
|
||||
# xmit.test
|
||||
#
|
||||
# This file tests the dp_send/dp_recv commands and large packet
|
||||
# transmissions.
|
||||
#
|
||||
# Large datagram transmissions are somewhat of a black box. It's
|
||||
# hard to predict what any given OS or Tcl will do if you don't read the
|
||||
# entire input. NT hangs. HP-UX just truncates the datagram to the
|
||||
# Tcl buffer size.
|
||||
#
|
||||
# In the cases below, we are setting the Tcl buffer to 8192. The
|
||||
# actual sockets should have a buffer of 8192 also. We then send
|
||||
# and recv 10,000 bytes over the connection.
|
||||
#
|
||||
|
||||
if {[string compare test [info procs test]] == 1} then {source ../tests/defs}
|
||||
|
||||
set sock1 {}
|
||||
set sock2 {}
|
||||
|
||||
set a 0123456789
|
||||
set h $a$a$a$a$a$a$a$a$a$a
|
||||
set t $h$h$h$h$h$h$h$h$h$h
|
||||
set w $t$t$t$t$t$t$t$t
|
||||
|
||||
# NOTE
|
||||
# w is now only 8,000 bytes long. I don't have time to debug it.
|
||||
#
|
||||
test xmit-1.1 {udp send/recv} {
|
||||
list [catch {
|
||||
set sock1 [dp_connect udp -host localhost -port 1999 -myport 2000]
|
||||
set sock2 [dp_connect udp -host localhost -port 2000 -myport 1999]
|
||||
dp_send $sock1 "Hey there!"
|
||||
dp_recv $sock2
|
||||
} msg] $msg
|
||||
} {0 {Hey there!}}
|
||||
|
||||
test xmit-1.2 {huge udp send/recv} {
|
||||
list [catch {
|
||||
fconfigure $sock1 -buffersize 8192
|
||||
fconfigure $sock2 -buffersize 8192
|
||||
puts $sock1 $w
|
||||
string compare [gets $sock2] $w
|
||||
} msg] $msg
|
||||
} {0 0}
|
||||
|
||||
catch {close $sock1}
|
||||
catch {close $sock2}
|
||||
|
||||
test xmit-1.3 {tcp send/recv} {
|
||||
list [catch {
|
||||
set server [dp_connect tcp -server 1 -myport 2906]
|
||||
set sock1 [dp_connect tcp -host localhost -port 2906 -async 1]
|
||||
after 200
|
||||
set sock2 [lindex [dp_accept $server] 0]
|
||||
dp_send $sock1 "Hey there!"
|
||||
dp_recv $sock2
|
||||
} msg] $msg
|
||||
} {0 {Hey there!}}
|
||||
|
||||
test xmit-1.4 {huge tcp send/recv} {
|
||||
list [catch {
|
||||
fconfigure $sock1 -buffersize 8192
|
||||
fconfigure $sock2 -buffersize 8192
|
||||
puts $sock1 $w
|
||||
string compare [gets $sock2] $w
|
||||
} msg] $msg
|
||||
} {0 0}
|
||||
|
||||
catch {close $server}
|
||||
catch {close $sock1}
|
||||
catch {close $sock2}
|
||||
|
||||
# See ipm.test for why this is necessary
|
||||
#
|
||||
if {$ipm == 1} {
|
||||
|
||||
test xmit-1.5 {ipm send/recv} {
|
||||
list [catch {
|
||||
set sock1 [dp_connect ipm -group 225.5.5.5 -myport 2000]
|
||||
dp_send $sock1 "Hey there!"
|
||||
dp_recv $sock1
|
||||
} msg] $msg
|
||||
} {0 {Hey there!}}
|
||||
|
||||
test xmit-1.6 {huge ipm send/recv} {
|
||||
list [catch {
|
||||
fconfigure $sock1 -buffersize 8192
|
||||
puts $sock1 $w
|
||||
string compare [gets $sock1] $w
|
||||
} msg] $msg
|
||||
} {0 0}
|
||||
|
||||
catch {close $sock1}
|
||||
catch {close $sock2}
|
||||
}
|
||||
|
||||
|
||||
|
||||
Reference in New Issue
Block a user