summaryrefslogtreecommitdiffstats
path: root/tests
diff options
context:
space:
mode:
Diffstat (limited to 'tests')
-rw-r--r--tests/README96
-rw-r--r--tests/env.test152
-rw-r--r--tests/event.test567
-rw-r--r--tests/http.test417
-rw-r--r--tests/parse.test556
-rw-r--r--tests/pkgMkIndex.test340
-rw-r--r--tests/socket.test1593
7 files changed, 0 insertions, 3721 deletions
diff --git a/tests/README b/tests/README
deleted file mode 100644
index 07915c9..0000000
--- a/tests/README
+++ /dev/null
@@ -1,96 +0,0 @@
-Tcl Test Suite
---------------
-
-RCS: @(#) $Id: README,v 1.2 1998/09/14 18:40:07 stanton Exp $
-
-This directory contains a set of validation tests for the Tcl
-commands. Each of the files whose name ends in ".test" is
-intended to fully exercise one or a few Tcl commands. The
-commands tested by a given file are listed in the first line
-of the file.
-
-You can run the tests in two ways:
- (a) type "make test" in ../unix; this will run all of the tests.
- (b) start up tcltest in this directory, then "source" the test
- file (for example, type "source parse.test"). To run all
- of the tests, type "source all".
-In either case no output will be generated if all goes well, except
-for a listing of the tests.. If there are errors then additional
-messages will appear in the format described below. Note: don't
-run the tests as superuser, since this will cause several of the tests
-to fail.
-
-The rest of this file provides additional information on the
-features of the testing environment.
-
-This approach to testing was designed and initially implemented
-by Mary Ann May-Pumphrey of Sun Microsystems. Many thanks to
-her for donating her work back to the public Tcl release.
-
-Definitions file:
------------------
-
-The file "defs" defines a collection of procedures and variables
-used to run the tests. It is read in automatically by each of the
-.test files if needed, but once it has been read once it will not
-be read again by the .test files. If you change defs while running
-tests you'll have to "source" it by hand to load its new contents.
-
-Test output:
-------------
-
-Normally, output only appears when there are errors. However, if
-the variable VERBOSE is set to 1 then tests will be run in "verbose"
-mode and output will be generated for each test regardless of
-whether it succeeded or failed. Test output consists of the
-following information:
-
- - the test identifier (which can be used to locate the test code
- in the .test file)
- - a brief description of the test
- - the contents of the test code
- - the actual results produced by the tests
- - a "PASSED" or "FAILED" message
- - the expected results (if the test failed)
-
-You can set VERBOSE either interactively (after the defs file has been
-read in), or you can change the default value in "defs".
-
-Selecting tests for execution:
-------------------------------
-
-Normally, all the tests in a file are run whenever the file is
-"source"d. However, you can select a specific set of tests using
-the global variable TESTS. This variable contains a pattern; any
-test whose identifier matches TESTS will be run. For example,
-the following interactive command causes all of the "for" tests in
-groups 2 and 4 to be executed:
-
- set TESTS {for-[24]*}
-
-TESTS defaults to *, but you can change the default in "defs" if
-you wish.
-
-Saving keystrokes:
-------------------
-
-A convenience procedure named "dotests" is included in file
-"defs". It takes two arguments--the name of the test file (such
-as "parse.test"), and a pattern selecting the tests you want to
-execute. It sets TESTS to the second argument, calls "source" on
-the file specified in the first argument, and restores TESTS to
-its pre-call value at the end.
-
-Batch vs. interactive execution:
---------------------------------
-
-The tests can be run in either batch or interactive mode. Batch
-mode refers to using I/O redirection from a UNIX shell. For example,
-the following command causes the tests in the file named "parse.test"
-to be executed:
-
- tclTest < parse.test > parse.test.results
-
-Users who want to execute the tests in this fashion need to first
-ensure that the file "defs" has proper values for the global
-variables that control the testing environment (VERBOSE and TESTS).
diff --git a/tests/env.test b/tests/env.test
deleted file mode 100644
index c66812b..0000000
--- a/tests/env.test
+++ /dev/null
@@ -1,152 +0,0 @@
-# Commands covered: none (tests environment variable implementation)
-#
-# This file contains a collection of tests for one or more of the Tcl
-# built-in commands. Sourcing this file into Tcl runs the tests and
-# generates output for errors. No output means no errors were found.
-#
-# Copyright (c) 1991-1993 The Regents of the University of California.
-# Copyright (c) 1994 Sun Microsystems, Inc.
-#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-# RCS: @(#) $Id: env.test,v 1.3 1998/09/30 20:52:00 escoffon Exp $
-
-if {[string compare test [info procs test]] == 1} then {source defs}
-
-#
-# These tests will run on any platform (and indeed crashed
-# on the Mac). So put them before you test for the existance
-# of exec.
-#
-test env-1.1 {propagation of env values to child interpreters} {
- catch {interp delete child}
- catch {unset env(test)}
- interp create child
- set env(test) garbage
- set return [child eval {set env(test)}]
- interp delete child
- unset env(test)
- set return
-} {garbage}
-#
-# This one crashed on Solaris under Tcl8.0, so we only
-# want to make sure it runs.
-#
-test env-1.2 {lappend to env value} {
- catch {unset env(test)}
- set env(test) aaaaaaaaaaaaaaaa
- append env(test) bbbbbbbbbbbbbb
- unset env(test)
-} {}
-if {[info commands exec] == ""} {
- puts "exec not implemented for this machine"
- return
-}
-
-if {$tcl_platform(os) == "Win32s"} {
- puts "Cannot run multiple copies of tcl at the same time under Win32s"
- return
-}
-
-set f [open printenv w]
-puts $f {
- proc lrem {listname name} {
- upvar $listname list
- set i [lsearch $list $name]
- if {$i >= 0} {
- set list [lreplace $list $i $i]
- }
- return $list
- }
-
- set names [lsort [array names env]]
- if {$tcl_platform(platform) == "windows"} {
- lrem names HOME
- lrem names COMSPEC
- lrem names ComSpec
- lrem names ""
- }
- foreach name {TCL_LIBRARY PATH LD_LIBRARY_PATH SHLIB_PATH} {
- lrem names $name
- }
- foreach p $names {
- puts "$p=$env($p)"
- }
-}
-close $f
-
-proc getenv {} {
- global printenv tcltest
- catch {exec $tcltest printenv} out
- if {$out == "child process exited abnormally"} {
- set out {}
- }
- return $out
-}
-
-# Save the current environment variables at the start of the test.
-
-foreach name [array names env] {
- set env2($name) $env($name)
- unset env($name)
-}
-
-# Added the following lines so that child tcltest can actually find its
-# library if the initial tcltest is run from a non-standard place.
-# ('saved' env vars)
-foreach name {TCL_LIBRARY PATH LD_LIBRARY_PATH SHLIB_PATH} {
- if {[info exists env2($name)]} {
- set env($name) $env2($name);
- }
-}
-
-test env-2.1 {adding environment variables} {
- getenv
-} {}
-
-set env(NAME1) "test string"
-test env-2.2 {adding environment variables} {
- getenv
-} {NAME1=test string}
-
-set env(NAME2) "more"
-test env-2.3 {adding environment variables} {
- getenv
-} {NAME1=test string
-NAME2=more}
-
-set env(XYZZY) "garbage"
-test env-2.4 {adding environment variables} {
- getenv
-} {NAME1=test string
-NAME2=more
-XYZZY=garbage}
-
-set env(NAME2) "new value"
-test env-3.1 {changing environment variables} {
- getenv
-} {NAME1=test string
-NAME2=new value
-XYZZY=garbage}
-
-unset env(NAME2)
-test env-4.1 {unsetting environment variables} {
- getenv
-} {NAME1=test string
-XYZZY=garbage}
-unset env(NAME1)
-test env-4.2 {unsetting environment variables} {
- getenv
-} {XYZZY=garbage}
-
-# Restore the environment variables at the end of the test.
-
-foreach name [array names env] {
- unset env($name)
-}
-foreach name [array names env2] {
- set env($name) $env2($name)
-}
-
-file delete printenv
diff --git a/tests/event.test b/tests/event.test
deleted file mode 100644
index 118bfc1..0000000
--- a/tests/event.test
+++ /dev/null
@@ -1,567 +0,0 @@
-# This file contains a collection of tests for the procedures in the file
-# tclEvent.c, which includes the "update", and "vwait" Tcl
-# commands. Sourcing this file into Tcl runs the tests and generates
-# output for errors. No output means no errors were found.
-#
-# Copyright (c) 1995-1997 Sun Microsystems, Inc.
-#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-# RCS: @(#) $Id: event.test,v 1.3 1998/09/14 18:40:08 stanton Exp $
-
-if {[string compare test [info procs test]] == 1} then {source defs}
-
-if {[catch {testfilehandler create 0 off off}] == 0 } {
- test event-1.1 {Tcl_CreateFileHandler, reading} {
- testfilehandler close
- testfilehandler create 0 readable off
- testfilehandler clear 0
- testfilehandler oneevent
- set result ""
- lappend result [testfilehandler counts 0]
- testfilehandler fillpartial 0
- testfilehandler oneevent
- lappend result [testfilehandler counts 0]
- testfilehandler oneevent
- lappend result [testfilehandler counts 0]
- testfilehandler close
- set result
- } {{0 0} {1 0} {2 0}}
- test event-1.2 {Tcl_CreateFileHandler, writing} {nonPortable} {
- # This test is non-portable because on some systems (e.g.
- # SunOS 4.1.3) pipes seem to be writable always.
- testfilehandler close
- testfilehandler create 0 off writable
- testfilehandler clear 0
- testfilehandler oneevent
- set result ""
- lappend result [testfilehandler counts 0]
- testfilehandler fillpartial 0
- testfilehandler oneevent
- lappend result [testfilehandler counts 0]
- testfilehandler fill 0
- testfilehandler oneevent
- lappend result [testfilehandler counts 0]
- testfilehandler close
- set result
- } {{0 1} {0 2} {0 2}}
- test event-1.3 {Tcl_DeleteFileHandler} {nonPortable} {
- testfilehandler close
- testfilehandler create 2 disabled disabled
- testfilehandler create 1 readable writable
- testfilehandler create 0 disabled disabled
- testfilehandler fillpartial 1
- set result ""
- testfilehandler oneevent
- lappend result [testfilehandler counts 1]
- testfilehandler oneevent
- lappend result [testfilehandler counts 1]
- testfilehandler oneevent
- lappend result [testfilehandler counts 1]
- testfilehandler create 1 off off
- testfilehandler oneevent
- lappend result [testfilehandler counts 1]
- testfilehandler close
- set result
- } {{0 1} {1 1} {1 2} {0 0}}
-
- test event-2.1 {Tcl_DeleteFileHandler} {nonPortable} {
- testfilehandler close
- testfilehandler create 2 disabled disabled
- testfilehandler create 1 readable writable
- testfilehandler fillpartial 1
- set result ""
- testfilehandler oneevent
- lappend result [testfilehandler counts 1]
- testfilehandler oneevent
- lappend result [testfilehandler counts 1]
- testfilehandler oneevent
- lappend result [testfilehandler counts 1]
- testfilehandler create 1 off off
- testfilehandler oneevent
- lappend result [testfilehandler counts 1]
- testfilehandler close
- set result
- } {{0 1} {1 1} {1 2} {0 0}}
- test event-2.2 {Tcl_DeleteFileHandler, fd reused & events still pending} {nonPortable} {
- testfilehandler close
- testfilehandler create 0 readable writable
- testfilehandler fillpartial 0
- set result ""
- testfilehandler oneevent
- lappend result [testfilehandler counts 0]
- testfilehandler close
- testfilehandler create 0 readable writable
- testfilehandler oneevent
- lappend result [testfilehandler counts 0]
- testfilehandler close
- set result
- } {{0 1} {0 0}}
-
- test event-3.1 {FileHandlerCheckProc, TCL_FILE_EVENTS off } {
- testfilehandler close
- testfilehandler create 1 readable writable
- testfilehandler fillpartial 1
- testfilehandler windowevent
- set result [testfilehandler counts 1]
- testfilehandler close
- set result
- } {0 0}
-
- test event-4.1 {FileHandlerEventProc, race between event and disabling} {nonPortable} {
- update
- testfilehandler close
- testfilehandler create 2 disabled disabled
- testfilehandler create 1 readable writable
- testfilehandler fillpartial 1
- set result ""
- testfilehandler oneevent
- lappend result [testfilehandler counts 1]
- testfilehandler oneevent
- lappend result [testfilehandler counts 1]
- testfilehandler oneevent
- lappend result [testfilehandler counts 1]
- testfilehandler create 1 disabled disabled
- testfilehandler oneevent
- lappend result [testfilehandler counts 1]
- testfilehandler close
- set result
- } {{0 1} {1 1} {1 2} {0 0}}
- test event-4.2 {FileHandlerEventProc, TCL_FILE_EVENTS off} {nonPortable} {
- update
- testfilehandler close
- testfilehandler create 1 readable writable
- testfilehandler create 2 readable writable
- testfilehandler fillpartial 1
- testfilehandler fillpartial 2
- testfilehandler oneevent
- set result ""
- lappend result [testfilehandler counts 1] [testfilehandler counts 2]
- testfilehandler windowevent
- lappend result [testfilehandler counts 1] [testfilehandler counts 2]
- testfilehandler close
- set result
- } {{0 0} {0 1} {0 0} {0 1}}
- testfilehandler close
- update
-}
-
-test event-5.1 {Tcl_BackgroundError, HandleBgErrors procedures} {
- catch {rename bgerror {}}
- proc bgerror msg {
- global errorInfo errorCode x
- lappend x [list $msg $errorInfo $errorCode]
- }
- after idle {error "a simple error"}
- after idle {open non_existent}
- after idle {set errorInfo foobar; set errorCode xyzzy}
- set x {}
- update idletasks
- rename bgerror {}
- set x
-} {{{a simple error} {a simple error
- while executing
-"error "a simple error""
- ("after" script)} NONE} {{couldn't open "non_existent": no such file or directory} {couldn't open "non_existent": no such file or directory
- while executing
-"open non_existent"
- ("after" script)} {POSIX ENOENT {no such file or directory}}}}
-test event-5.2 {Tcl_BackgroundError, HandleBgErrors procedures} {
- catch {rename bgerror {}}
- proc bgerror msg {
- global x
- lappend x $msg
- return -code break
- }
- after idle {error "a simple error"}
- after idle {open non_existent}
- set x {}
- update idletasks
- rename bgerror {}
- set x
-} {{a simple error}}
-
-test event-6.1 {BgErrorDeleteProc procedure} {
- catch {interp delete foo}
- interp create foo
- foo eval {
- proc bgerror args {
- global errorInfo
- set f [open err.out r+]
- seek $f 0 end
- puts $f "$args $errorInfo"
- close $f
- }
- after 100 {error "first error"}
- after 100 {error "second error"}
- }
- makeFile Unmodified err.out
- after 100 {interp delete foo}
- after 200
- update
- set f [open err.out r]
- set result [read $f]
- close $f
- removeFile err.out
- set result
-} {Unmodified
-}
-
-test event-7.1 {bgerror / regular} {
- set errRes {}
- proc bgerror {err} {
- global errRes;
- set errRes $err;
- }
- after 0 {error err1}
- vwait errRes;
- set errRes;
-} err1
-
-test event-7.2 {bgerror / accumulation} {
- set errRes {}
- proc bgerror {err} {
- global errRes;
- lappend errRes $err;
- }
- after 0 {error err1}
- after 0 {error err2}
- after 0 {error err3}
- update
- set errRes;
-} {err1 err2 err3}
-
-test event-7.3 {bgerror / accumulation / break} {
- set errRes {}
- proc bgerror {err} {
- global errRes;
- lappend errRes $err;
- return -code break "skip!";
- }
- after 0 {error err1}
- after 0 {error err2}
- after 0 {error err3}
- update
- set errRes;
-} err1
-
-test event-7.4 {tkerror is nothing special anymore to tcl} {
- set errRes {}
- # we don't just rename bgerror to empty because it could then
- # be autoloaded...
- proc bgerror {err} {
- global errRes;
- lappend errRes "bg:$err";
- }
- proc tkerror {err} {
- global errRes;
- lappend errRes "tk:$err";
- }
- after 0 {error err1}
- update
- rename tkerror {}
- set errRes
-} bg:err1
-
-# someday : add a test checking that
-# when there is no bgerror, an error msg goes to stderr
-# ideally one would use sub interp and transfer a fake stderr
-# to it, unfortunatly the current interp tcl API does not allow
-# that. the other option would be to use fork a test but it
-# then becomes more a file/exec test than a bgerror test.
-
-# end of bgerror tests
-catch {rename bgerror {}}
-
-
-if {[info commands testexithandler] != ""} {
- test event-8.1 {Tcl_CreateExitHandler procedure} {stdio} {
- set child [open |[list [info nameofexecutable]] r+]
- puts $child "testexithandler create 41; testexithandler create 4"
- puts $child "testexithandler create 6; exit"
- flush $child
- set result [read $child]
- close $child
- set result
- } {even 6
-even 4
-odd 41
-}
-
- test event-9.1 {Tcl_DeleteExitHandler procedure} {stdio} {
- set child [open |[list [info nameofexecutable]] r+]
- puts $child "testexithandler create 41; testexithandler create 4"
- puts $child "testexithandler create 6; testexithandler delete 41"
- puts $child "testexithandler create 16; exit"
- flush $child
- set result [read $child]
- close $child
- set result
- } {even 16
-even 6
-even 4
-}
- test event-9.2 {Tcl_DeleteExitHandler procedure} {stdio} {
- set child [open |[list [info nameofexecutable]] r+]
- puts $child "testexithandler create 41; testexithandler create 4"
- puts $child "testexithandler create 6; testexithandler delete 4"
- puts $child "testexithandler create 16; exit"
- flush $child
- set result [read $child]
- close $child
- set result
- } {even 16
-even 6
-odd 41
-}
- test event-9.3 {Tcl_DeleteExitHandler procedure} {stdio} {
- set child [open |[list [info nameofexecutable]] r+]
- puts $child "testexithandler create 41; testexithandler create 4"
- puts $child "testexithandler create 6; testexithandler delete 6"
- puts $child "testexithandler create 16; exit"
- flush $child
- set result [read $child]
- close $child
- set result
- } {even 16
-even 4
-odd 41
-}
- test event-9.4 {Tcl_DeleteExitHandler procedure} {stdio} {
- set child [open |[list [info nameofexecutable]] r+]
- puts $child "testexithandler create 41; testexithandler delete 41"
- puts $child "testexithandler create 16; exit"
- flush $child
- set result [read $child]
- close $child
- set result
- } {even 16
-}
-}
-
-test event-10.1 {Tcl_Exit procedure} {stdio} {
- set child [open |[list [info nameofexecutable]] r+]
- puts $child "exit 3"
- list [catch {close $child} msg] $msg [lindex $errorCode 0] \
- [lindex $errorCode 2]
-} {1 {child process exited abnormally} CHILDSTATUS 3}
-
-test event-11.1 {Tcl_VwaitCmd procedure} {
- list [catch {vwait} msg] $msg
-} {1 {wrong # args: should be "vwait name"}}
-test event-11.2 {Tcl_VwaitCmd procedure} {
- list [catch {vwait a b} msg] $msg
-} {1 {wrong # args: should be "vwait name"}}
-test event-11.3 {Tcl_VwaitCmd procedure} {
- catch {unset x}
- set x 1
- list [catch {vwait x(1)} msg] $msg
-} {1 {can't trace "x(1)": variable isn't array}}
-test event-11.4 {Tcl_VwaitCmd procedure} {
- foreach i [after info] {
- after cancel $i
- }
- after 10; update; # On Mac make sure update won't take long
- after 100 {set x x-done}
- after 200 {set y y-done}
- after 300 {set z z-done}
- after idle {set q q-done}
- set x before
- set y before
- set z before
- set q before
- list [vwait y] $x $y $z $q
-} {{} x-done y-done before q-done}
-
-foreach i [after info] {
- after cancel $i
-}
-
-test event-11.5 {Tcl_VwaitCmd procedure: round robin scheduling, 2 sources} {socket} {
- set f1 [open test1 w]
- proc accept {s args} {
- puts $s foobar
- close $s
- }
- set s1 [socket -server accept 5001]
- set s2 [socket 127.0.0.1 5001]
- close $s1
- set x 0
- set y 0
- set z 0
- fileevent $s2 readable { incr z }
- vwait z
- fileevent $f1 writable { incr x; if { $y == 3 } { set z done } }
- fileevent $s2 readable { incr y; if { $x == 3 } { set z done } }
- vwait z
- close $f1
- close $s2
- file delete test1 test2
- list $x $y $z
-} {3 3 done}
-test event-11.6 {Tcl_VwaitCmd procedure: round robin scheduling, same source} {
- file delete test1 test2
- set f1 [open test1 w]
- set f2 [open test2 w]
- set x 0
- set y 0
- set z 0
- update
- fileevent $f1 writable { incr x; if { $y == 3 } { set z done } }
- fileevent $f2 writable { incr y; if { $x == 3 } { set z done } }
- vwait z
- close $f1
- close $f2
- file delete test1 test2
- list $x $y $z
-} {3 3 done}
-
-
-test event-12.1 {Tcl_UpdateCmd procedure} {
- list [catch {update a b} msg] $msg
-} {1 {wrong # args: should be "update ?idletasks?"}}
-test event-12.2 {Tcl_UpdateCmd procedure} {
- list [catch {update bogus} msg] $msg
-} {1 {bad option "bogus": must be idletasks}}
-test event-12.3 {Tcl_UpdateCmd procedure} {
- foreach i [after info] {
- after cancel $i
- }
- after 500 {set x after}
- after idle {set y after}
- after idle {set z "after, y = $y"}
- set x before
- set y before
- set z before
- update idletasks
- list $x $y $z
-} {before after {after, y = after}}
-test event-12.4 {Tcl_UpdateCmd procedure} {
- foreach i [after info] {
- after cancel $i
- }
- after 10; update; # On Mac make sure update won't take long
- after 200 {set x x-done}
- after 600 {set y y-done}
- after idle {set z z-done}
- set x before
- set y before
- set z before
- after 300
- update
- list $x $y $z
-} {x-done before z-done}
-
-if {[info commands testfilehandler] != ""} {
- test event-13.1 {Tcl_WaitForFile procedure, readable} unixOnly {
- foreach i [after info] {
- after cancel $i
- }
- after 100 set x timeout
- testfilehandler close
- testfilehandler create 1 off off
- set x "no timeout"
- set result [testfilehandler wait 1 readable 0]
- update
- testfilehandler close
- list $result $x
- } {{} {no timeout}}
- test event-13.2 {Tcl_WaitForFile procedure, readable} unixOnly {
- foreach i [after info] {
- after cancel $i
- }
- after 100 set x timeout
- testfilehandler close
- testfilehandler create 1 off off
- set x "no timeout"
- set result [testfilehandler wait 1 readable 100]
- update
- testfilehandler close
- list $result $x
- } {{} timeout}
- test event-13.3 {Tcl_WaitForFile procedure, readable} unixOnly {
- foreach i [after info] {
- after cancel $i
- }
- after 100 set x timeout
- testfilehandler close
- testfilehandler create 1 off off
- testfilehandler fillpartial 1
- set x "no timeout"
- set result [testfilehandler wait 1 readable 100]
- update
- testfilehandler close
- list $result $x
- } {readable {no timeout}}
- test event-13.4 {Tcl_WaitForFile procedure, writable} {unixOnly nonPortable} {
- foreach i [after info] {
- after cancel $i
- }
- after 100 set x timeout
- testfilehandler close
- testfilehandler create 1 off off
- testfilehandler fill 1
- set x "no timeout"
- set result [testfilehandler wait 1 writable 0]
- update
- testfilehandler close
- list $result $x
- } {{} {no timeout}}
- test event-13.5 {Tcl_WaitForFile procedure, writable} {unixOnly nonPortable} {
- foreach i [after info] {
- after cancel $i
- }
- after 100 set x timeout
- testfilehandler close
- testfilehandler create 1 off off
- testfilehandler fill 1
- set x "no timeout"
- set result [testfilehandler wait 1 writable 100]
- update
- testfilehandler close
- list $result $x
- } {{} timeout}
- test event-13.6 {Tcl_WaitForFile procedure, writable} unixOnly {
- foreach i [after info] {
- after cancel $i
- }
- after 100 set x timeout
- testfilehandler close
- testfilehandler create 1 off off
- set x "no timeout"
- set result [testfilehandler wait 1 writable 100]
- update
- testfilehandler close
- list $result $x
- } {writable {no timeout}}
- test event-13.7 {Tcl_WaitForFile procedure, don't call other event handlers} unixOnly {
- foreach i [after info] {
- after cancel $i
- }
- after 100 lappend x timeout
- after idle lappend x idle
- testfilehandler close
- testfilehandler create 1 off off
- set x ""
- set result [list [testfilehandler wait 1 readable 200] $x]
- update
- testfilehandler close
- lappend result $x
- } {{} {} {timeout idle}}
-}
-
-if {[info commands testfilewait] != ""} {
- test event-13.8 {Tcl_WaitForFile procedure, waiting indefinitely} unixOnly {
- set f [open "|sleep 2" r]
- set result ""
- lappend result [testfilewait $f readable 100]
- lappend result [testfilewait $f readable -1]
- close $f
- set result
- } {{} readable}
-}
-
-foreach i [after info] {
- after cancel $i
-}
diff --git a/tests/http.test b/tests/http.test
deleted file mode 100644
index c4ddbf8..0000000
--- a/tests/http.test
+++ /dev/null
@@ -1,417 +0,0 @@
-# Commands covered: http::config, http::geturl, http::wait, http::reset
-#
-# This file contains a collection of tests for the http script library.
-# Sourcing this file into Tcl runs the tests and
-# generates output for errors. No output means no errors were found.
-#
-# Copyright (c) 1991-1993 The Regents of the University of California.
-# Copyright (c) 1994-1996 Sun Microsystems, Inc.
-#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-#
-# RCS: @(#) $Id: http.test,v 1.3 1998/11/03 02:00:54 welch Exp $
-
-if {[string compare test [info procs test]] == 1} then {source defs}
-
-if {[catch {package require http 2.0}]} {
- if {[info exist http2]} {
- catch {puts stderr "Cannot load http 2.0 package"}
- return
- } else {
- catch {puts stderr "Running http 2.0 tests in slave interp"}
- set interp [interp create http2]
- $interp eval [list set http2 "running"]
- $interp eval [list source [info script]]
- interp delete $interp
- return
- }
-}
-
-############### The httpd_ procedures implement a stub http server. ########
-proc httpd_init {{port 8015}} {
- socket -server httpdAccept $port
-}
-proc httpd_log {args} {
- global httpLog
- if {[info exists httpLog] && $httpLog} {
- puts stderr "httpd: [join $args { }]"
- }
-}
-array set httpdErrors {
- 204 {No Content}
- 400 {Bad Request}
- 404 {Not Found}
- 503 {Service Unavailable}
- 504 {Service Temporarily Unavailable}
- }
-
-proc httpdError {sock code args} {
- global httpdErrors
- puts $sock "$code $httpdErrors($code)"
- httpd_log "error: [join $args { }]"
-}
-proc httpdAccept {newsock ipaddr port} {
- global httpd
- upvar #0 httpd$newsock data
-
- fconfigure $newsock -blocking 0 -translation {auto crlf}
- httpd_log $newsock Connect $ipaddr $port
- set data(ipaddr) $ipaddr
- fileevent $newsock readable [list httpdRead $newsock]
-}
-
-# read data from a client request
-
-proc httpdRead { sock } {
- upvar #0 httpd$sock data
-
- set readCount [gets $sock line]
- if {![info exists data(state)]} {
- if [regexp {(POST|GET|HEAD) ([^?]+)\??([^ ]*) HTTP/1.0} \
- $line x data(proto) data(url) data(query)] {
- set data(state) mime
- httpd_log $sock Query $line
- } else {
- httpdError $sock 400
- httpd_log $sock Error "bad first line:$line"
- httpdSockDone $sock
- }
- return
- }
-
- # string compare $readCount 0 maps -1 to -1, 0 to 0, and > 0 to 1
-
- set state [string compare $readCount 0],$data(state),$data(proto)
- httpd_log $sock $state
- switch -- $state {
- -1,mime,HEAD -
- -1,mime,GET -
- -1,mime,POST {
- # gets would block
- return
- }
- 0,mime,HEAD -
- 0,mime,GET -
- 0,query,POST { httpdRespond $sock }
- 0,mime,POST { set data(state) query }
- 1,mime,HEAD -
- 1,mime,POST -
- 1,mime,GET {
- if [regexp {([^:]+):[ ]*(.*)} $line dummy key value] {
- set data(mime,[string tolower $key]) $value
- }
- }
- 1,query,POST {
- append data(query) $line
- httpdRespond $sock
- }
- default {
- if [eof $sock] {
- httpd_log $sock Error "unexpected eof on <$data(url)> request"
- } else {
- httpd_log $sock Error "unhandled state <$state> fetching <$data(url)>"
- }
- httpdError $sock 404
- httpdSockDone $sock
- }
- }
-}
-proc httpdSockDone { sock } {
-upvar #0 httpd$sock data
- unset data
- close $sock
-}
-
-# Respond to the query.
-
-set bindata "This is binary data\x0d\x0amore\x0dmore\x0amore\x00null"
-proc httpdRespond { sock } {
- global httpd bindata port
- upvar #0 httpd$sock data
-
- if {[string match *binary* $data(url)]} {
- set html "$bindata[info hostname]:$port$data(url)"
- set type application/octet-stream
- } else {
- set type text/html
-
- set html "<html><head><title>HTTP/1.0 TEST</title></head><body>
-<h1>Hello, World!</h1>
-<h2>$data(proto) $data(url)</h2>
-"
- if {[info exists data(query)] && [string length $data(query)]} {
- append html "<h2>Query</h2>\n<dl>\n"
- foreach {key value} [split $data(query) &=] {
- append html "<dt>$key<dd>$value\n"
- if {[string compare $key timeout] == 0} {
- # Simulate a timeout by not responding,
- # but clean up our socket later.
-
- after 50 [list httpdSockDone $sock]
- httpd_log $sock Noresponse ""
- return
- }
- }
- append html </dl>\n
- }
- append html </body></html>
- }
-
- if {$data(proto) == "HEAD"} {
- puts $sock "HTTP/1.0 200 OK"
- } else {
- puts $sock "HTTP/1.0 200 Data follows"
- }
- puts $sock "Date: [clock format [clock clicks]]"
- puts $sock "Content-Type: $type"
- puts $sock "Content-Length: [string length $html]"
- puts $sock ""
- if {$data(proto) != "HEAD"} {
- fconfigure $sock -translation binary
- puts -nonewline $sock $html
- }
- httpd_log $sock Done ""
- httpdSockDone $sock
-}
-##################### end server ###########################
-
-set port 8010
-if [catch {httpd_init $port} listen] {
- puts stderr "Cannot start http server, http test skipped"
- unset port
- return
-}
-
-test http-1.1 {http::config} {
- http::config
-} {-accept */* -proxyfilter http::ProxyRequired -proxyhost {} -proxyport {} -useragent {Tcl http client package 2.0}}
-
-test http-1.2 {http::config} {
- http::config -proxyfilter
-} http::ProxyRequired
-
-test http-1.3 {http::config} {
- catch {http::config -junk}
-} 1
-
-test http-1.4 {http::config} {
- set savedconf [http::config]
- http::config -proxyhost nowhere.come -proxyport 8080 -proxyfilter myFilter -useragent "Tcl Test Suite"
- set x [http::config]
- eval http::config $savedconf
- set x
-} {-accept */* -proxyfilter myFilter -proxyhost nowhere.come -proxyport 8080 -useragent {Tcl Test Suite}}
-
-test http-1.5 {http::config} {
- catch {http::config -proxyhost {} -junk 8080}
-} 1
-
-test http-2.1 {http::reset} {
- catch {http::reset http#1}
-} 0
-
-test http-3.1 {http::geturl} {
- catch {http::geturl -bogus flag}
-} 1
-test http-3.2 {http::geturl} {
- catch {http::geturl http:junk} err
- set err
-} {Unsupported URL: http:junk}
-
-set url [info hostname]:$port
-test http-3.3 {http::geturl} {
- set token [http::geturl $url]
- http::data $token
-} "<html><head><title>HTTP/1.0 TEST</title></head><body>
-<h1>Hello, World!</h1>
-<h2>GET /</h2>
-</body></html>"
-
-set tail /a/b/c
-set url [info hostname]:$port/a/b/c
-set binurl [info hostname]:$port/binary
-
-test http-3.4 {http::geturl} {
- set token [http::geturl $url]
- http::data $token
-} "<html><head><title>HTTP/1.0 TEST</title></head><body>
-<h1>Hello, World!</h1>
-<h2>GET $tail</h2>
-</body></html>"
-
-proc selfproxy {host} {
- global port
- return [list [info hostname] $port]
-}
-test http-3.5 {http::geturl} {
- http::config -proxyfilter selfproxy
- set token [http::geturl $url]
- http::config -proxyfilter http::ProxyRequired
- http::data $token
-} "<html><head><title>HTTP/1.0 TEST</title></head><body>
-<h1>Hello, World!</h1>
-<h2>GET http://$url</h2>
-</body></html>"
-
-test http-3.6 {http::geturl} {
- http::config -proxyfilter bogus
- set token [http::geturl $url]
- http::config -proxyfilter http::ProxyRequired
- http::data $token
-} "<html><head><title>HTTP/1.0 TEST</title></head><body>
-<h1>Hello, World!</h1>
-<h2>GET $tail</h2>
-</body></html>"
-
-test http-3.7 {http::geturl} {
- set token [http::geturl $url -headers {Pragma no-cache}]
- http::data $token
-} "<html><head><title>HTTP/1.0 TEST</title></head><body>
-<h1>Hello, World!</h1>
-<h2>GET $tail</h2>
-</body></html>"
-
-test http-3.8 {http::geturl} {
- set token [http::geturl $url -query Name=Value&Foo=Bar]
- http::data $token
-} "<html><head><title>HTTP/1.0 TEST</title></head><body>
-<h1>Hello, World!</h1>
-<h2>POST $tail</h2>
-<h2>Query</h2>
-<dl>
-<dt>Name<dd>Value
-<dt>Foo<dd>Bar
-</dl>
-</body></html>"
-
-test http-3.9 {http::geturl} {
- set token [http::geturl $url -validate 1]
- http::code $token
-} "HTTP/1.0 200 OK"
-
-
-test http-4.1 {http::Event} {
- set token [http::geturl $url]
- upvar #0 $token data
- array set meta $data(meta)
- expr ($data(totalsize) == $meta(Content-Length))
-} 1
-
-test http-4.2 {http::Event} {
- set token [http::geturl $url]
- upvar #0 $token data
- array set meta $data(meta)
- string compare $data(type) [string trim $meta(Content-Type)]
-} 0
-
-test http-4.3 {http::Event} {
- set token [http::geturl $url]
- http::code $token
-} {HTTP/1.0 200 Data follows}
-
-test http-4.4 {http::Event} {
- set out [open testfile w]
- set token [http::geturl $url -channel $out]
- close $out
- set in [open testfile]
- set x [read $in]
- close $in
- file delete testfile
- set x
-} "<html><head><title>HTTP/1.0 TEST</title></head><body>
-<h1>Hello, World!</h1>
-<h2>GET $tail</h2>
-</body></html>"
-
-test http-4.5 {http::Event} {
- set out [open testfile w]
- set token [http::geturl $url -channel $out]
- close $out
- upvar #0 $token data
- file delete testfile
- expr $data(currentsize) == $data(totalsize)
-} 1
-
-test http-4.6 {http::Event} {
- set out [open testfile w]
- set token [http::geturl $binurl -channel $out]
- close $out
- set in [open testfile]
- fconfigure $in -translation binary
- set x [read $in]
- close $in
- file delete testfile
- set x
-} "$bindata$binurl"
-
-proc myProgress {token total current} {
- global progress httpLog
- if {[info exists httpLog] && $httpLog} {
- puts "progress $total $current"
- }
- set progress [list $total $current]
-}
-if 0 {
- # This test hangs on Windows95 because the client never gets EOF
- set httpLog 1
- test http-4.6 {http::Event} {
- set token [http::geturl $url -blocksize 50 -progress myProgress]
- set progress
- } {111 111}
-}
-test http-4.7 {http::Event} {
- set token [http::geturl $url -progress myProgress]
- set progress
-} {111 111}
-test http-4.8 {http::Event} {
- set token [http::geturl $url]
- http::status $token
-} {ok}
-test http-4.9 {http::Event} {
- set token [http::geturl $url -progress myProgress]
- http::code $token
-} {HTTP/1.0 200 Data follows}
-test http-4.10 {http::Event} {
- set token [http::geturl $url -progress myProgress]
- http::size $token
-} {111}
-test http-4.11 {http::Event} {
- set token [http::geturl $url -timeout 1 -command {#}]
- http::reset $token
- http::status $token
-} {reset}
-test http-4.12 {http::Event} {
- set token [http::geturl $url?timeout=10 -timeout 1 -command {#}]
- http::wait $token
- http::status $token
-} {timeout}
-
-test http-5.1 {http::formatQuery} {
- http::formatQuery name1 value1 name2 "value two"
-} {name1=value1&name2=value+two}
-
-test http-5.2 {http::formatQuery} {
- http::formatQuery name1 ~bwelch name2 \xa1\xa2\xa2
-} {name1=%7ebwelch&name2=%a1%a2%a2}
-
-test http-5.3 {http::formatQuery} {
- http::formatQuery lines "line1\nline2\nline3"
-} {lines=line1%0d%0aline2%0d%0aline3}
-
-test http-6.1 {http::ProxyRequired} {
- http::config -proxyhost [info hostname] -proxyport $port
- set token [http::geturl $url]
- http::wait $token
- http::config -proxyhost {} -proxyport {}
- upvar #0 $token data
- set data(body)
-} "<html><head><title>HTTP/1.0 TEST</title></head><body>
-<h1>Hello, World!</h1>
-<h2>GET http://$url</h2>
-</body></html>"
-
-unset url
-unset port
-close $listen
diff --git a/tests/parse.test b/tests/parse.test
deleted file mode 100644
index 7019b7a..0000000
--- a/tests/parse.test
+++ /dev/null
@@ -1,556 +0,0 @@
-# Commands covered: set (plus basic command syntax). Also tests
-# the procedures in the file tclParse.c.
-#
-# This file contains a collection of tests for one or more of the Tcl
-# built-in commands. Sourcing this file into Tcl runs the tests and
-# generates output for errors. No output means no errors were found.
-#
-# Copyright (c) 1991-1993 The Regents of the University of California.
-# Copyright (c) 1994-1996 Sun Microsystems, Inc.
-#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-# RCS: @(#) $Id: parse.test,v 1.2 1998/09/14 18:40:12 stanton Exp $
-
-if {[string compare test [info procs test]] == 1} then {source defs}
-
-proc fourArgs {a b c d} {
- global arg1 arg2 arg3 arg4
- set arg1 $a
- set arg2 $b
- set arg3 $c
- set arg4 $d
-}
-
-proc getArgs args {
- global argv
- set argv $args
-}
-
-# Basic argument parsing.
-
-test parse-1.1 {basic argument parsing} {
- set arg1 {}
- fourArgs a b c d
- list $arg1 $arg2 $arg3 $arg4
-} {a b c d}
-test parse-1.2 {basic argument parsing} {
- set arg1 {}
- eval "fourArgs 123\v4\f56\r7890"
- list $arg1 $arg2 $arg3 $arg4
-} {123 4 56 7890}
-
-# Quotes.
-
-test parse-2.1 {quotes and variable-substitution} {
- getArgs "a b c" d
- set argv
-} {{a b c} d}
-test parse-2.2 {quotes and variable-substitution} {
- set a 101
- getArgs "a$a b c"
- set argv
-} {{a101 b c}}
-test parse-2.3 {quotes and variable-substitution} {
- set argv "xy[format xabc]"
- set argv
-} {xyxabc}
-test parse-2.4 {quotes and variable-substitution} {
- set argv "xy\t"
- set argv
-} xy\t
-test parse-2.5 {quotes and variable-substitution} {
- set argv "a b c
-d e f"
- set argv
-} a\ b\tc\nd\ e\ f
-test parse-2.6 {quotes and variable-substitution} {
- set argv a"bcd"e
- set argv
-} {a"bcd"e}
-
-# Braces.
-
-test parse-3.1 {braces} {
- getArgs {a b c} d
- set argv
-} "{a b c} d"
-test parse-3.2 {braces} {
- set a 101
- set argv {a$a b c}
- set b [string index $argv 1]
- set b
-} {$}
-test parse-3.3 {braces} {
- set argv {a[format xyz] b}
- string length $argv
-} 15
-test parse-3.4 {braces} {
- set argv {a\nb\}}
- string length $argv
-} 6
-test parse-3.5 {braces} {
- set argv {{{{}}}}
- set argv
-} "{{{}}}"
-test parse-3.6 {braces} {
- set argv a{{}}b
- set argv
-} "a{{}}b"
-test parse-3.7 {braces} {
- set a [format "last]"]
- set a
-} {last]}
-
-# Command substitution.
-
-test parse-4.1 {command substitution} {
- set a [format xyz]
- set a
-} xyz
-test parse-4.2 {command substitution} {
- set a a[format xyz]b[format q]
- set a
-} axyzbq
-test parse-4.3 {command substitution} {
- set a a[
-set b 22;
-format %s $b
-
-]b
- set a
-} a22b
-test parse-4.4 {command substitution} {
- set a 7.7
- if [catch {expr int($a)}] {set a foo}
- set a
-} 7.7
-
-# Variable substitution.
-
-test parse-5.1 {variable substitution} {
- set a 123
- set b $a
- set b
-} 123
-test parse-5.2 {variable substitution} {
- set a 345
- set b x$a.b
- set b
-} x345.b
-test parse-5.3 {variable substitution} {
- set _123z xx
- set b $_123z^
- set b
-} xx^
-test parse-5.4 {variable substitution} {
- set a 78
- set b a${a}b
- set b
-} a78b
-test parse-5.5 {variable substitution} {catch {$_non_existent_} msg} 1
-test parse-5.6 {variable substitution} {
- catch {$_non_existent_} msg
- set msg
-} {can't read "_non_existent_": no such variable}
-test parse-5.7 {array variable substitution} {
- catch {unset a}
- set a(xyz) 123
- set b $a(xyz)foo
- set b
-} 123foo
-test parse-5.8 {array variable substitution} {
- catch {unset a}
- set "a(x y z)" 123
- set b $a(x y z)foo
- set b
-} 123foo
-test parse-5.9 {array variable substitution} {
- catch {unset a}; catch {unset qqq}
- set "a(x y z)" qqq
- set $a([format x]\ y [format z]) foo
- set qqq
-} foo
-test parse-5.10 {array variable substitution} {
- catch {unset a}
- list [catch {set b $a(22)} msg] $msg
-} {1 {can't read "a(22)": no such variable}}
-test parse-5.11 {array variable substitution} {
- set b a$!
- set b
-} {a$!}
-test parse-5.12 {array variable substitution} {
- set b a$()
- set b
-} {a$()}
-catch {unset a}
-test parse-5.13 {array variable substitution} {
- catch {unset a}
- set long {This is a very long variable, long enough to cause storage \
- allocation to occur in Tcl_ParseVar. If that storage isn't getting \
- freed up correctly, then a core leak will occur when this test is \
- run. This text is probably beginning to sound like drivel, but I've \
- run out of things to say and I need more characters still.}
- set a($long) 777
- set b $a($long)
- list $b [array names a]
-} {777 {{This is a very long variable, long enough to cause storage \
- allocation to occur in Tcl_ParseVar. If that storage isn't getting \
- freed up correctly, then a core leak will occur when this test is \
- run. This text is probably beginning to sound like drivel, but I've \
- run out of things to say and I need more characters still.}}}
-test parse-5.14 {array variable substitution} {
- catch {unset a}; catch {unset b}; catch {unset a1}
- set a1(22) foo
- set a(foo) bar
- set b $a($a1(22))
- set b
-} bar
-catch {unset a}; catch {unset a1}
-
-# Backslash substitution.
-
-set errNum 1
-proc bsCheck {char num} {
- global errNum
-; test parse-6.$errNum {backslash substitution} {
- scan $char %c value
- set value
- } $num
- set errNum [expr $errNum+1]
-}
-
-bsCheck \b 8
-bsCheck \e 101
-bsCheck \f 12
-bsCheck \n 10
-bsCheck \r 13
-bsCheck \t 9
-bsCheck \v 11
-bsCheck \{ 123
-bsCheck \} 125
-bsCheck \[ 91
-bsCheck \] 93
-bsCheck \$ 36
-bsCheck \ 32
-bsCheck \; 59
-bsCheck \\ 92
-bsCheck \Ca 67
-bsCheck \Ma 77
-bsCheck \CMa 67
-bsCheck \8a 8
-bsCheck \14 12
-bsCheck \141 97
-bsCheck \340 224
-bsCheck b\0 98
-bsCheck \x 120
-bsCheck \xa 10
-bsCheck \x41 65
-bsCheck \x541 65
-
-test parse-6.1 {backslash substitution} {
- set a "\a\c\n\]\}"
- string length $a
-} 5
-test parse-6.2 {backslash substitution} {
- set a {\a\c\n\]\}}
- string length $a
-} 10
-test parse-6.3 {backslash substitution} {
- set a "abc\
-def"
- set a
-} {abc def}
-test parse-6.4 {backslash substitution} {
- set a {abc\
-def}
- set a
-} {abc def}
-test parse-6.5 {backslash substitution} {
- set msg {}
- set a xxx
- set error [catch {if {24 < \
- 35} {set a 22} {set \
- a 33}} msg]
- list $error $msg $a
-} {0 22 22}
-test parse-6.6 {backslash substitution} {
- eval "concat abc\\"
-} "abc\\"
-test parse-6.7 {backslash substitution} {
- eval "concat \\\na"
-} "a"
-test parse-6.8 {backslash substitution} {
- eval "concat x\\\n a"
-} "x a"
-test parse-6.9 {backslash substitution} {
- eval "concat \\x"
-} "x"
-test parse-6.10 {backslash substitution} {
- eval "list a b\\\nc d"
-} {a b c d}
-test parse-6.11 {backslash substitution} {
- eval "list a \"b c\"\\\nd e"
-} {a {b c} d e}
-
-# Semi-colon.
-
-test parse-7.1 {semi-colons} {
- set b 0
- getArgs a;set b 2
- set argv
-} a
-test parse-7.2 {semi-colons} {
- set b 0
- getArgs a;set b 2
- set b
-} 2
-test parse-7.3 {semi-colons} {
- getArgs a b ; set b 1
- set argv
-} {a b}
-test parse-7.4 {semi-colons} {
- getArgs a b ; set b 1
- set b
-} 1
-
-# The following checks are to ensure that the interpreter's result
-# gets re-initialized by Tcl_Eval in all the right places.
-
-test parse-8.1 {result initialization} {concat abc} abc
-test parse-8.2 {result initialization} {concat abc; proc foo {} {}} {}
-test parse-8.3 {result initialization} {concat abc; proc foo {} $a} {}
-test parse-8.4 {result initialization} {proc foo {} [concat abc]} {}
-test parse-8.5 {result initialization} {concat abc; } abc
-test parse-8.6 {result initialization} {
- eval {
- concat abc
-}} abc
-test parse-8.7 {result initialization} {} {}
-test parse-8.8 {result initialization} {concat abc; ; ;} abc
-
-# Syntax errors.
-
-test parse-9.1 {syntax errors} {catch "set a \{bcd" msg} 1
-test parse-9.2 {syntax errors} {
- catch "set a \{bcd" msg
- set msg
-} {missing close-brace}
-test parse-9.3 {syntax errors} {catch {set a "bcd} msg} 1
-test parse-9.4 {syntax errors} {
- catch {set a "bcd} msg
- set msg
-} {quoted string doesn't terminate properly}
-test parse-9.5 {syntax errors} {catch {set a "bcd"xy} msg} 1
-test parse-9.6 {syntax errors} {
- catch {set a "bcd"xy} msg
- set msg
-} {quoted string doesn't terminate properly}
-test parse-9.7 {syntax errors} {catch "set a {bcd}xy" msg} 1
-test parse-9.8 {syntax errors} {
- catch "set a {bcd}xy" msg
- set msg
-} {argument word in braces doesn't terminate properly}
-test parse-9.9 {syntax errors} {catch {set a [format abc} msg} 1
-test parse-9.10 {syntax errors} {
- catch {set a [format abc} msg
- set msg
-} {missing close-bracket or close-brace}
-test parse-9.11 {syntax errors} {catch gorp-a-lot msg} 1
-test parse-9.12 {syntax errors} {
- catch gorp-a-lot msg
- set msg
-} {invalid command name "gorp-a-lot"}
-test parse-9.13 {syntax errors} {
- set a [concat {a}\
- {b}]
- set a
-} {a b}
-test parse-9.14 {syntax errors} {
- list [catch {eval \$x[format "%01000d" 0](} msg] $msg $errorInfo
-} {1 {missing )} {missing )
- (parsing index for array "x000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000")
- while compiling
-"$x0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000 ..."
- ("eval" body line 1)
- invoked from within
-"eval \$x[format "%01000d" 0]("}}
-test parse-9.15 {syntax errors, missplaced braces} {
- catch {
- proc misplaced_end_brace {} {
- set what foo
- set when [expr ${what}size - [set off$what]}]
- } msg
- set msg
-} {wrong # args: should be "proc name args body"}
-test parse-9.16 {syntax errors, missplaced braces} {
- catch {
- set a {
- set what foo
- set when [expr ${what}size - [set off$what]}]
- } msg
- set msg
-} {argument word in braces doesn't terminate properly}
-
-# Long values (stressing storage management)
-
-set a {1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH}
-
-test parse-10.1 {long values} {
- string length $a
-} 214
-test parse-10.2 {long values} {
- llength $a
-} 43
-test parse-10.3 {long values} {
- set b "1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH"
- set b
-} $a
-test parse-10.4 {long values} {
- set b "$a"
- set b
-} $a
-test parse-10.5 {long values} {
- set b [set a]
- set b
-} $a
-test parse-10.6 {long values} {
- set b [concat 1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH]
- string length $b
-} 214
-test parse-10.7 {long values} {
- set b [concat 1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH]
- llength $b
-} 43
-test parse-10.8 {long values} {
- set b
-} $a
-test parse-10.9 {long values} {
- set a [concat 0000 1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH IIII JJJJ KKKK LLLL MMMM NNNN OOOO PPPP QQQQ RRRR SSSS TTTT UUUU VVVV WWWW XXXX YYYY ZZZZ]
- llength $a
-} 62
-set i 0
-foreach j [concat 0000 1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH IIII JJJJ KKKK LLLL MMMM NNNN OOOO PPPP QQQQ RRRR SSSS TTTT UUUU VVVV WWWW XXXX YYYY ZZZZ] {
- set test [string index 0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ $i]
- set test $test$test$test$test
- set i [expr $i+1]
- test parse-10.10 {long values} {
- set j
- } $test
-}
-test parse-10.11 {test buffer overflow in backslashes in braces} {
- expr {"a" == {xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyy\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101}}
-} 0
-
-test parse-11.1 {comments} {
- set a old
- eval { # set a new}
- set a
-} {old}
-test parse-11.2 {comments} {
- set a old
- eval " # set a new\nset a new"
- set a
-} {new}
-test parse-11.3 {comments} {
- set a old
- eval " # set a new\\\nset a new"
- set a
-} {old}
-test parse-11.4 {comments} {
- set a old
- eval " # set a new\\\\\nset a new"
- set a
-} {new}
-
-test parse-12.1 {comments at the end of a bracketed script} {
- set x "[
-expr 1+1
-# skip this!
-]"
-} {2}
-
-if {[info command testwordend] == "testwordend"} {
- test parse-13.1 {TclWordEnd procedure} {
- testwordend " \n abc"
- } {c}
- test parse-13.2 {TclWordEnd procedure} {
- testwordend " \\\n"
- } {}
- test parse-13.3 {TclWordEnd procedure} {
- testwordend " \\\n "
- } { }
- test parse-13.4 {TclWordEnd procedure} {
- testwordend {"abc"}
- } {"}
- test parse-13.5 {TclWordEnd procedure} {
- testwordend {{xyz}}
- } \}
- test parse-13.6 {TclWordEnd procedure} {
- testwordend {{a{}b{}\}} xyz}
- } "\} xyz"
- test parse-13.7 {TclWordEnd procedure} {
- testwordend {abc[this is a]def ghi}
- } {f ghi}
- test parse-13.8 {TclWordEnd procedure} {
- testwordend "puts\\\n\n "
- } "s\\\n\n "
- test parse-13.9 {TclWordEnd procedure} {
- testwordend "puts\\\n "
- } "s\\\n "
- test parse-13.10 {TclWordEnd procedure} {
- testwordend "puts\\\n xyz"
- } "s\\\n xyz"
- test parse-13.11 {TclWordEnd procedure} {
- testwordend {a$x.$y(a long index) foo}
- } ") foo"
- test parse-13.12 {TclWordEnd procedure} {
- testwordend {abc; def}
- } {; def}
- test parse-13.13 {TclWordEnd procedure} {
- testwordend {abc def}
- } {c def}
- test parse-13.14 {TclWordEnd procedure} {
- testwordend {abc def}
- } {c def}
- test parse-13.15 {TclWordEnd procedure} {
- testwordend "abc\ndef"
- } "c\ndef"
- test parse-13.16 {TclWordEnd procedure} {
- testwordend "abc"
- } {c}
- test parse-13.17 {TclWordEnd procedure} {
- testwordend "a\000bc"
- } {c}
- test parse-13.18 {TclWordEnd procedure} {
- testwordend \[a\000\]
- } {]}
- test parse-13.19 {TclWordEnd procedure} {
- testwordend \"a\000\"
- } {"}
- test parse-13.20 {TclWordEnd procedure} {
- testwordend a{\000}b
- } {b}
- test parse-13.21 {TclWordEnd procedure} {
- testwordend " \000b"
- } {b}
-}
-
-test parse-14.1 {TclScriptEnd procedure} {
- info complete {puts [
- expr 1+1
- #this is a comment ]}
-} {0}
-test parse-14.2 {TclScriptEnd procedure} {
- info complete "abc\\\n"
-} {0}
-test parse-14.3 {TclScriptEnd procedure} {
- info complete "abc\\\\\n"
-} {1}
-test parse-14.4 {TclScriptEnd procedure} {
- info complete "xyz \[abc \{abc\]"
-} {0}
-test parse-14.5 {TclScriptEnd procedure} {
- info complete "xyz \[abc"
-} {0}
diff --git a/tests/pkgMkIndex.test b/tests/pkgMkIndex.test
deleted file mode 100644
index 3251feb..0000000
--- a/tests/pkgMkIndex.test
+++ /dev/null
@@ -1,340 +0,0 @@
-# This file contains tests for the pkg_mkIndex command.
-# Note that the tests are limited to Tcl scripts only, there are no shared
-# libraries against which to test.
-#
-# Sourcing this file into Tcl runs the tests and generates output for
-# errors. No output means no errors were found.
-#
-# Copyright (c) 1998 by Scriptics Corporation.
-# All rights reserved.
-#
-# RCS: @(#) $Id: pkgMkIndex.test,v 1.4 1998/11/12 05:54:21 welch Exp $
-
-if {[string compare test [info procs test]] == 1} then {source defs}
-
-# Add the pkg1 directory to auto_path, so that its packages can be found.
-# packages in pkg1 are used to test indexing of packages in pkg.
-# Make sure that the path to pkg1 is absolute.
-
-set scriptDir [file dirname [info script]]
-set oldDir [pwd]
-lappend auto_path [file join [pwd] $scriptDir pkg1]
-
-namespace eval pkgtest {
- # Namespace for procs we can discard
-}
-
-# pkgtest::parseArgs --
-#
-# Parse an argument list.
-#
-# Arguments:
-# <flags> (optional) arguments starting with a dash are collected
-# as options to pkg_mkIndex and passed to pkg_mkIndex.
-# dirPath the directory to index
-# pattern0 pattern to index
-# ... pattern to index
-# patternN pattern to index
-#
-# Results:
-# Returns a three element list:
-# 0: the options
-# 1: the directory to index
-# 2: the patterns list
-
-proc pkgtest::parseArgs { args } {
- set options ""
-
- set argc [llength $args]
- for {set iarg 0} {$iarg < $argc} {incr iarg} {
- set a [lindex $args $iarg]
- if {[regexp {^-} $a]} {
- lappend options $a
- if {[string compare -load $a] == 0} {
- incr iarg
- lappend options [lindex $args $iarg]
- }
- } else {
- break
- }
- }
-
- set dirPath [lindex $args $iarg]
- incr iarg
- set patternList [lrange $args $iarg end]
-
- return [list $options $dirPath $patternList]
-}
-
-# pkgtest::parseIndex --
-#
-# Loads a pkgIndex.tcl file, records all the calls to "package ifneeded".
-#
-# Arguments:
-# filePath path to the pkgIndex.tcl file.
-#
-# Results:
-# Returns a list, in "array set/get" format, where the keys are the package
-# name and version (in the form "$name:$version"), and the values the rest
-# of the command line.
-
-proc pkgtest::parseIndex { filePath } {
- # create a slave interpreter, where we override "package ifneeded"
-
- set slave [interp create]
- if {[catch {
- $slave eval {
- rename package package_original
- proc package { args } {
- if {[string compare [lindex $args 0] ifneeded] == 0} {
- set pkg [lindex $args 1]
- set ver [lindex $args 2]
- set ::PKGS($pkg:$ver) [lindex $args 3]
- } else {
- return [eval package_original $args]
- }
- }
- array set ::PKGS {}
- }
-
- set dir [file dirname $filePath]
- $slave eval {set curdir [pwd]}
- $slave eval [list cd $dir]
- $slave eval [list set dir $dir]
- $slave eval [list source [file tail $filePath]]
- $slave eval {cd $curdir}
-
- # Create the list in sorted order, so that we don't get spurious
- # errors because the order has changed.
-
- array set P {}
- foreach {k v} [$slave eval {array get ::PKGS}] {
- set P($k) $v
- }
-
- set PKGS ""
- foreach k [lsort [array names P]] {
- lappend PKGS $k $P($k)
- }
- } err]} {
- set ei $::errorInfo
- set ec $::errorCode
-
- catch {interp delete $slave}
-
- error $ei $ec
- }
-
- interp delete $slave
-
- return $PKGS
-}
-
-# pkgtest::createIndex --
-#
-# Runs pkg_mkIndex for the given directory and set of patterns.
-# This procedure deletes any pkgIndex.tcl file in the target directory,
-# then runs pkg_mkIndex.
-#
-# Arguments:
-# <flags> (optional) arguments starting with a dash are collected
-# as options to pkg_mkIndex and passed to pkg_mkIndex.
-# dirPath the directory to index
-# pattern0 pattern to index
-# ... pattern to index
-# patternN pattern to index
-#
-# Results:
-# Returns a two element list:
-# 0: 1 if the procedure encountered an error, 0 otherwise.
-# 1: the error result if element 0 was 1
-
-proc pkgtest::createIndex { args } {
- set parsed [eval parseArgs $args]
- set options [lindex $parsed 0]
- set dirPath [lindex $parsed 1]
- set patternList [lindex $parsed 2]
-
- if {[catch {
- file delete [file join $dirPath pkgIndex.tcl]
- eval pkg_mkIndex $options $dirPath $patternList
- } err]} {
- return [list 1 $err]
- }
-
- return [list 0 {}]
-}
-
-# makePkgList --
-#
-# Takes the output of a pkgtest::parseIndex call, filters it and returns a
-# cleaned up list of packages and their actions.
-#
-# Arguments:
-# inList output from a pkgtest::parseIndex.
-#
-# Results:
-# Returns a list of two element lists:
-# 0: the name:version
-# 1: a list describing the package.
-# For tclPkgSetup packages it consists of:
-# 0: the keyword tclPkgSetup
-# 1: the first file to source, with its exported procedures
-# 2: the second file ...
-# N: the N-1st file ...
-
-proc makePkgList { inList } {
- set pkgList ""
-
- foreach {k v} $inList {
- switch [lindex $v 0] {
- tclPkgSetup {
- set l tclPkgSetup
- foreach s [lindex $v 4] {
- lappend l $s
- }
- }
-
- source {
- set l $v
- }
-
- default {
- error "can't handle $k $v"
- }
- }
-
- lappend pkgList [list $k $l]
- }
-
- return $pkgList
-}
-
-# pkgtest::runIndex --
-#
-# Runs pkg_mkIndex, parses the generated index file.
-#
-# Arguments:
-# <flags> (optional) arguments starting with a dash are collected
-# as options to pkg_mkIndex and passed to pkg_mkIndex.
-# dirPath the directory to index
-# pattern0 pattern to index
-# ... pattern to index
-# patternN pattern to index
-#
-# Results:
-# Returns a two element list:
-# 0: 1 if the procedure encountered an error, 0 otherwise.
-# 1: if no error, this is the parsed generated index file, in the format
-# returned by pkgtest::parseIndex.
-# If error, this is the error result.
-
-proc pkgtest::runIndex { args } {
- set rv [eval createIndex $args]
- if {[lindex $rv 0] == 0} {
- set parsed [eval parseArgs $args]
- set dirPath [lindex $parsed 1]
- set idxFile [file join $dirPath pkgIndex.tcl]
-
- if {[catch {
- set result [list 0 [makePkgList [parseIndex $idxFile]]]
- } err]} {
- set result [list 1 $err]
- }
- file delete $idxFile
- } else {
- set result $rv
- }
-
- return $result
-}
-
-# If there is no match to the patterns, make sure the directory hasn't
-# changed on us
-
-test pkgMkIndex-1.1 {nothing matches pattern - current dir is the same} {
- list [pkgtest::runIndex pkg nomatch.tcl] [pwd]
-} [list {1 {no files matched glob pattern "nomatch.tcl"}} [pwd]]
-cd $oldDir ;# 'cause 8.0.3 is left in the wrong place
-test pkgMkIndex-2.1 {simple package} {
- pkgtest::runIndex pkg simple.tcl
-} {0 {{simple:1.0 {tclPkgSetup {simple.tcl source {::simple::lower ::simple::upper}}}}}}
-
-test pkgMkIndex-2.2 {simple package - use -direct} {
- pkgtest::runIndex -direct pkg simple.tcl
-} "0 {{simple:1.0 {source [file join pkg simple.tcl]}}}"
-
-test pkgMkIndex-3.1 {simple package with global symbols} {
- pkgtest::runIndex pkg global.tcl
-} {0 {{global:1.0 {tclPkgSetup {global.tcl source {global_lower global_upper}}}}}}
-
-test pkgMkIndex-4.1 {split package} {
- pkgtest::runIndex pkg pkg2_a.tcl pkg2_b.tcl
-} {0 {{pkg2:1.0 {tclPkgSetup {pkg2_a.tcl source ::pkg2::p2-1} {pkg2_b.tcl source ::pkg2::p2-2}}}}}
-
-test pkgMkIndex-4.2 {split package - direct loading} {
- pkgtest::runIndex -direct pkg pkg2_a.tcl pkg2_b.tcl
-} "0 {{pkg2:1.0 {source [file join pkg pkg2_a.tcl]
-source [file join pkg pkg2_b.tcl]}}}"
-
-# This will fail, with "direct1" procedures in the list of procedures
-# provided by std.
-# It may also fail, if tclblend is in the auto_path, with an additional
-# command "loadJava" which comes from the tclblend pkgIndex.tcl file.
-# Both failures are caused by Tcl code executed in pkgIndex.tcl.
-
-test pkgMkIndex-5.1 {requires -direct package} {
- pkgtest::runIndex pkg std.tcl
-} {0 {{std:1.0 {tclPkgSetup {std.tcl source {::std::p1 ::std::p2}}}}}}
-
-test pkgMkIndex-6.1 {pkg1 requires pkg3} {
- pkgtest::runIndex pkg pkg1.tcl pkg3.tcl
-} {0 {{pkg1:1.0 {tclPkgSetup {pkg1.tcl source {::pkg1::p1-1 ::pkg1::p1-2}}}} {pkg3:1.0 {tclPkgSetup {pkg3.tcl source {::pkg3::p3-1 ::pkg3::p3-2}}}}}}
-
-test pkgMkIndex-6.2 {pkg1 requires pkg3 - use -direct} {
- pkgtest::runIndex -direct pkg pkg1.tcl pkg3.tcl
-} "0 {{pkg1:1.0 {source [file join pkg pkg1.tcl]}} {pkg3:1.0 {source [file join pkg pkg3.tcl]}}}"
-
-test pkgMkIndex-7.1 {pkg4 uses pkg3} {
- pkgtest::runIndex pkg pkg4.tcl pkg3.tcl
-} {0 {{pkg3:1.0 {tclPkgSetup {pkg3.tcl source {::pkg3::p3-1 ::pkg3::p3-2}}}} {pkg4:1.0 {tclPkgSetup {pkg4.tcl source {::pkg4::p4-1 ::pkg4::p4-2}}}}}}
-
-test pkgMkIndex-7.2 {pkg4 uses pkg3 - use -direct} {
- pkgtest::runIndex -direct pkg pkg4.tcl pkg3.tcl
-} "0 {{pkg3:1.0 {source [file join pkg pkg3.tcl]}} {pkg4:1.0 {source [file join pkg pkg4.tcl]}}}"
-
-test pkgMkIndex-8.1 {pkg5 uses pkg2} {
- pkgtest::runIndex pkg pkg5.tcl pkg2_a.tcl pkg2_b.tcl
-} {0 {{pkg2:1.0 {tclPkgSetup {pkg2_a.tcl source ::pkg2::p2-1} {pkg2_b.tcl source ::pkg2::p2-2}}} {pkg5:1.0 {tclPkgSetup {pkg5.tcl source {::pkg5::p5-1 ::pkg5::p5-2}}}}}}
-
-test pkgMkIndex-8.2 {pkg5 uses pkg2 - use -direct} {
- pkgtest::runIndex -direct pkg pkg5.tcl pkg2_a.tcl pkg2_b.tcl
-} "0 {{pkg2:1.0 {source [file join pkg pkg2_a.tcl]
-source [file join pkg pkg2_b.tcl]}} {pkg5:1.0 {source [file join pkg pkg5.tcl]}}}"
-
-test pkgMkIndex-9.1 {circular packages} {
- pkgtest::runIndex pkg circ1.tcl circ2.tcl circ3.tcl
-} {0 {{circ1:1.0 {tclPkgSetup {circ1.tcl source {::circ1::c1-1 ::circ1::c1-2 ::circ1::c1-3 ::circ1::c1-4}}}} {circ2:1.0 {tclPkgSetup {circ2.tcl source {::circ2::c2-1 ::circ2::c2-2}}}} {circ3:1.0 {tclPkgSetup {circ3.tcl source ::circ3::c3-1}}}}}
-
-# Try to find one of the DLLs in the dltest directory
-set x [file join [pwd] [file dirname [info script]]]
-set x [file join $x ../unix/dltest/pkga[info sharedlibextension]]
-if {[file exists $x]} {
- file copy -force $x pkg
- test pkgMkIndex-10.1 {package in DLL and script} {
- pkgtest::runIndex pkg pkga[info sharedlibextension] pkga.tcl
- } {0 {{Pkga:1.0 {tclPkgSetup {pkga.so load {pkga_eq pkga_quote}} {pkga.tcl source pkga_neq}}}}}
- test pkgMkIndex-10.2 {package in DLL hidden by -load} {
- pkgtest::runIndex -load Pkg* -- pkg pkga[info sharedlibextension]
- } {0 {}}
-} else {
- puts "Skipping pkgMkIndex-10.1 (index of DLL and script)"
-}
-
-#
-# cleanup
-#
-if {![info exist TESTS]} {
- file delete [file join pkg pkgIndex.tcl]
- namespace delete pkgtest
-}
diff --git a/tests/socket.test b/tests/socket.test
deleted file mode 100644
index 5ff563a..0000000
--- a/tests/socket.test
+++ /dev/null
@@ -1,1593 +0,0 @@
-# Commands tested in this file: socket.
-#
-# This file contains a collection of tests for one or more of the Tcl
-# built-in commands. Sourcing this file into Tcl runs the tests and
-# generates output for errors. No output means no errors were found.
-#
-# Copyright (c) 1994-1996 Sun Microsystems, Inc.
-#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-# Running socket tests with a remote server:
-# ------------------------------------------
-#
-# Some tests in socket.test depend on the existence of a remote server to
-# which they connect. The remote server must be an instance of tcltest and it
-# must run the script found in the file "remote.tcl" in this directory. You
-# can start the remote server on any machine reachable from the machine on
-# which you want to run the socket tests, by issuing:
-#
-# tcltest remote.tcl -port 2048 # Or choose another port number.
-#
-# If the machine you are running the remote server on has several IP
-# interfaces, you can choose which interface the server listens on for
-# connections by specifying the -address command line flag, so:
-#
-# tcltest remote.tcl -address your.machine.com
-#
-# These options can also be set by environment variables. On Unix, you can
-# type these commands to the shell from which the remote server is started:
-#
-# shell% setenv serverPort 2048
-# shell% setenv serverAddress your.machine.com
-#
-# and subsequently you can start the remote server with:
-#
-# tcltest remote.tcl
-#
-# to have it listen on port 2048 on the interface your.machine.com.
-#
-# When the server starts, it prints out a detailed message containing its
-# configuration information, and it will block until killed with a Ctrl-C.
-# Once the remote server exists, you can run the tests in socket.test with
-# the server by setting two Tcl variables:
-#
-# % set remoteServerIP <name or address of machine on which server runs>
-# % set remoteServerPort 2048
-#
-# These variables are also settable from the environment. On Unix, you can:
-#
-# shell% setenv remoteServerIP machine.where.server.runs
-# shell% senetv remoteServerPort 2048
-#
-# The preamble of the socket.test file checks to see if the variables are set
-# either in Tcl or in the environment; if they are, it attempts to connect to
-# the server. If the connection is successful, the tests using the remote
-# server will be performed; otherwise, it will attempt to start the remote
-# server (via exec) on platforms that support this, on the local host,
-# listening at port 2048. If all fails, a message is printed and the tests
-# using the remote server are not performed.
-#
-# RCS: @(#) $Id: socket.test,v 1.6 1998/12/04 01:01:55 stanton Exp $
-
-if {[string compare test [info procs test]] == 1} then {source defs}
-
-if {$testConfig(socket) == 0} {
- return
-}
-
-#
-# If remoteServerIP or remoteServerPort are not set, check in the
-# environment variables for externally set values.
-#
-
-if {![info exists remoteServerIP]} {
- if {[info exists env(remoteServerIP)]} {
- set remoteServerIP $env(remoteServerIP)
- }
-}
-if {![info exists remoteServerPort]} {
- if {[info exists env(remoteServerIP)]} {
- set remoteServerPort $env(remoteServerPort)
- } else {
- if {[info exists remoteServerIP]} {
- set remoteServerPort 2048
- }
- }
-}
-
-#
-# Check if we're supposed to do tests against the remote server
-#
-
-set doTestsWithRemoteServer 1
-if {![info exists remoteServerIP] && ($tcl_platform(platform) != "macintosh")} {
- set remoteServerIP localhost
-}
-if {($doTestsWithRemoteServer == 1) && (![info exists remoteServerPort])} {
- set remoteServerPort 2048
-}
-
-# Attempt to connect to a remote server if one is already running. If it
-# is not running or for some other reason the connect fails, attempt to
-# start the remote server on the local host listening on port 2048. This
-# is only done on platforms that support exec (i.e. not on the Mac). On
-# platforms that do not support exec, the remote server must be started
-# by the user before running the tests.
-
-set remoteProcChan ""
-set commandSocket ""
-if {$doTestsWithRemoteServer} {
- catch {close $commandSocket}
- if {[catch {set commandSocket [socket $remoteServerIP \
- $remoteServerPort]}] != 0} {
- if {[info commands exec] == ""} {
- set noRemoteTestReason "can't exec"
- set doTestsWithRemoteServer 0
- } elseif {$testConfig(win32s)} {
- set noRemoteTestReason "\ncan't run multiple instances of tcltest under win32s."
- set doTestsWithRemoteServer 0
- } else {
- set remoteServerIP localhost
- if {[catch {set remoteProcChan \
- [open "|[list $tcltest remote.tcl \
- -serverIsSilent \
- -port $remoteServerPort \
- -address $remoteServerIP]" \
- w+]} \
- msg] == 0} {
- after 1000
- if {[catch {set commandSocket [socket $remoteServerIP \
- $remoteServerPort]} msg] == 0} {
- fconfigure $commandSocket -translation crlf -buffering line
- } else {
- set noRemoteTestReason $msg
- set doTestsWithRemoteServer 0
- }
- } else {
- set noRemoteTestReason "$msg $tcltest"
- set doTestsWithRemoteServer 0
- }
- }
- } else {
- fconfigure $commandSocket -translation crlf -buffering line
- }
-}
-
-if {$doTestsWithRemoteServer == 0} {
- puts "Skipping tests with remote server. See tests/socket.test for"
- puts "information on how to run remote server."
- if {[info exists VERBOSE] && ($VERBOSE != 0)} {
- puts "Reason for not doing remote tests: $noRemoteTestReason"
- }
-}
-
-#
-# If we do the tests, define a command to send a command to the
-# remote server.
-#
-
-if {$doTestsWithRemoteServer == 1} {
- proc sendCommand {c} {
- global commandSocket
-
- if {[eof $commandSocket]} {
- error "remote server disappeared"
- }
-
- if {[catch {puts $commandSocket $c} msg]} {
- error "remote server disappaered: $msg"
- }
- if {[catch {puts $commandSocket "--Marker--Marker--Marker--"} msg]} {
- error "remote server disappeared: $msg"
- }
-
- set resp ""
- while {1} {
- set line [gets $commandSocket]
- if {[eof $commandSocket]} {
- error "remote server disappaered"
- }
- if {[string compare $line "--Marker--Marker--Marker--"] == 0} {
- if {[string compare [lindex $resp 0] error] == 0} {
- error [lindex $resp 1]
- } else {
- return [lindex $resp 1]
- }
- } else {
- append resp $line "\n"
- }
- }
- }
-}
-
-test socket-1.1 {arg parsing for socket command} {
- list [catch {socket -server} msg] $msg
-} {1 {no argument given for -server option}}
-test socket-1.2 {arg parsing for socket command} {
- list [catch {socket -server foo} msg] $msg
-} {1 {wrong # args: should be either:
-socket ?-myaddr addr? ?-myport myport? ?-async? host port
-socket -server command ?-myaddr addr? port}}
-test socket-1.3 {arg parsing for socket command} {
- list [catch {socket -myaddr} msg] $msg
-} {1 {no argument given for -myaddr option}}
-test socket-1.4 {arg parsing for socket command} {
- list [catch {socket -myaddr 127.0.0.1} msg] $msg
-} {1 {wrong # args: should be either:
-socket ?-myaddr addr? ?-myport myport? ?-async? host port
-socket -server command ?-myaddr addr? port}}
-test socket-1.5 {arg parsing for socket command} {
- list [catch {socket -myport} msg] $msg
-} {1 {no argument given for -myport option}}
-test socket-1.6 {arg parsing for socket command} {
- list [catch {socket -myport xxxx} msg] $msg
-} {1 {expected integer but got "xxxx"}}
-test socket-1.7 {arg parsing for socket command} {
- list [catch {socket -myport 2522} msg] $msg
-} {1 {wrong # args: should be either:
-socket ?-myaddr addr? ?-myport myport? ?-async? host port
-socket -server command ?-myaddr addr? port}}
-test socket-1.8 {arg parsing for socket command} {
- list [catch {socket -froboz} msg] $msg
-} {1 {bad option "-froboz", must be -async, -myaddr, -myport, or -server}}
-test socket-1.9 {arg parsing for socket command} {
- list [catch {socket -server foo -myport 2521 3333} msg] $msg
-} {1 {Option -myport is not valid for servers}}
-test socket-1.10 {arg parsing for socket command} {
- list [catch {socket host 2528 -junk} msg] $msg
-} {1 {wrong # args: should be either:
-socket ?-myaddr addr? ?-myport myport? ?-async? host port
-socket -server command ?-myaddr addr? port}}
-test socket-1.11 {arg parsing for socket command} {
- list [catch {socket -server callback 2520 --} msg] $msg
-} {1 {wrong # args: should be either:
-socket ?-myaddr addr? ?-myport myport? ?-async? host port
-socket -server command ?-myaddr addr? port}}
-test socket-1.12 {arg parsing for socket command} {
- list [catch {socket foo badport} msg] $msg
-} {1 {expected integer but got "badport"}}
-
-test socket-2.1 {tcp connection} {stdio} {
- removeFile script
- set f [open script w]
- puts $f {
- set timer [after 2000 "set x timed_out"]
- set f [socket -server accept 2828]
- proc accept {file addr port} {
- global x
- set x done
- close $file
- }
- puts ready
- vwait x
- after cancel $timer
- close $f
- puts $x
- }
- close $f
- set f [open "|[list $tcltest script]" r]
- gets $f x
- if {[catch {socket localhost 2828} msg]} {
- set x $msg
- } else {
- lappend x [gets $f]
- close $msg
- }
- lappend x [gets $f]
- close $f
- set x
-} {ready done {}}
-
-if [info exists port] {
- incr port
-} else {
- set port [expr 2048 + [pid]%1024]
-}
-test socket-2.2 {tcp connection with client port specified} {stdio} {
- removeFile script
- set f [open script w]
- puts $f {
- set timer [after 2000 "set x done"]
- set f [socket -server accept 2828]
- proc accept {file addr port} {
- global x
- puts "[gets $file] $port"
- close $file
- set x done
- }
- puts ready
- vwait x
- after cancel $timer
- close $f
- }
- close $f
- set f [open "|[list $tcltest script]" r]
- gets $f x
- global port
- if {[catch {socket -myport $port localhost 2828} sock]} {
- set x $sock
- close [socket localhost 2828]
- puts stderr $sock
- } else {
- puts $sock hello
- flush $sock
- lappend x [gets $f]
- close $sock
- }
- close $f
- set x
-} [list ready "hello $port"]
-test socket-2.3 {tcp connection with client interface specified} {stdio} {
- removeFile script
- set f [open script w]
- puts $f {
- set timer [after 2000 "set x done"]
- set f [socket -server accept 2828]
- proc accept {file addr port} {
- global x
- puts "[gets $file] $addr"
- close $file
- set x done
- }
- puts ready
- vwait x
- after cancel $timer
- close $f
- }
- close $f
- set f [open "|[list $tcltest script]" r]
- gets $f x
- if {[catch {socket -myaddr localhost localhost 2828} sock]} {
- set x $sock
- } else {
- puts $sock hello
- flush $sock
- lappend x [gets $f]
- close $sock
- }
- close $f
- set x
-} {ready {hello 127.0.0.1}}
-test socket-2.4 {tcp connection with server interface specified} {stdio} {
- removeFile script
- set f [open script w]
- puts $f {
- set timer [after 2000 "set x done"]
- set f [socket -server accept -myaddr [info hostname] 2828]
- proc accept {file addr port} {
- global x
- puts "[gets $file]"
- close $file
- set x done
- }
- puts ready
- vwait x
- after cancel $timer
- close $f
- }
- close $f
- set f [open "|[list $tcltest script]" r]
- gets $f x
- if {[catch {socket [info hostname] 2828} sock]} {
- set x $sock
- } else {
- puts $sock hello
- flush $sock
- lappend x [gets $f]
- close $sock
- }
- close $f
- set x
-} {ready hello}
-test socket-2.5 {tcp connection with redundant server port} {stdio} {
- removeFile script
- set f [open script w]
- puts $f {
- set timer [after 2000 "set x done"]
- set f [socket -server accept 2828]
- proc accept {file addr port} {
- global x
- puts "[gets $file]"
- close $file
- set x done
- }
- puts ready
- vwait x
- after cancel $timer
- close $f
- }
- close $f
- set f [open "|[list $tcltest script]" r]
- gets $f x
- if {[catch {socket localhost 2828} sock]} {
- set x $sock
- } else {
- puts $sock hello
- flush $sock
- lappend x [gets $f]
- close $sock
- }
- close $f
- set x
-} {ready hello}
-test socket-2.6 {tcp connection} {} {
- set status ok
- if {![catch {set sock [socket localhost 2828]}]} {
- if {![catch {gets $sock}]} {
- set status broken
- }
- close $sock
- }
- set status
-} ok
-test socket-2.7 {echo server, one line} {stdio} {
- removeFile script
- set f [open script w]
- puts $f {
- set timer [after 2000 "set x done"]
- set f [socket -server accept 2828]
- proc accept {s a p} {
- fileevent $s readable [list echo $s]
- fconfigure $s -translation lf -buffering line
- }
- proc echo {s} {
- set l [gets $s]
- if {[eof $s]} {
- global x
- close $s
- set x done
- } else {
- puts $s $l
- }
- }
- puts ready
- vwait x
- after cancel $timer
- close $f
- puts done
- }
- close $f
- set f [open "|[list $tcltest script]" r]
- gets $f
- set s [socket localhost 2828]
- fconfigure $s -buffering line -translation lf
- puts $s "hello abcdefghijklmnop"
- set x [gets $s]
- close $s
- set y [gets $f]
- close $f
- list $x $y
-} {{hello abcdefghijklmnop} done}
-test socket-2.8 {echo server, loop 50 times, single connection} {stdio} {
- removeFile script
- set f [open script w]
- puts $f {
- set f [socket -server accept 2828]
- proc accept {s a p} {
- fileevent $s readable [list echo $s]
- fconfigure $s -buffering line
- }
- proc echo {s} {
- global i
- set l [gets $s]
- if {[eof $s]} {
- global x
- close $s
- set x done
- } else {
- incr i
- puts $s $l
- }
- }
- set i 0
- puts ready
- set timer [after 20000 "set x done"]
- vwait x
- after cancel $timer
- close $f
- puts "done $i"
- }
- close $f
- set f [open "|[list $tcltest script]" r]
- gets $f
- set s [socket localhost 2828]
- fconfigure $s -buffering line
- for {set x 0} {$x < 50} {incr x} {
- puts $s "hello abcdefghijklmnop"
- gets $s
- }
- close $s
- set x [gets $f]
- close $f
- set x
-} {done 50}
-test socket-2.9 {socket conflict} {stdio} {
- set s [socket -server accept 2828]
- removeFile script
- set f [open script w]
- puts $f {set f [socket -server accept 2828]}
- close $f
- set f [open "|[list $tcltest script]" r]
- gets $f
- after 100
- set x [list [catch {close $f} msg] $msg]
- close $s
- set x
-} {1 {couldn't open socket: address already in use
- while executing
-"socket -server accept 2828"
- (file "script" line 1)}}
-test socket-2.10 {close on accept, accepted socket lives} {
- set done 0
- set timer [after 20000 "set done timed_out"]
- set ss [socket -server accept 2830]
- proc accept {s a p} {
- global ss
- close $ss
- fileevent $s readable "readit $s"
- fconfigure $s -trans lf
- }
- proc readit {s} {
- global done
- gets $s
- close $s
- set done 1
- }
- set cs [socket [info hostname] 2830]
- puts $cs hello
- close $cs
- vwait done
- after cancel $timer
- set done
-} 1
-test socket-2.11 {detecting new data} {
- proc accept {s a p} {
- global sock
- set sock $s
- }
-
- set s [socket -server accept 2400]
- set sock ""
- set s2 [socket localhost 2400]
- vwait sock
- puts $s2 one
- flush $s2
- after 500
- fconfigure $sock -blocking 0
- set result [gets $sock]
- lappend result [gets $sock]
- fconfigure $sock -blocking 1
- puts $s2 two
- flush $s2
- fconfigure $sock -blocking 0
- lappend result [gets $sock]
- fconfigure $sock -blocking 1
- close $s2
- close $s
- close $sock
- set result
-} {one {} two}
-
-
-test socket-3.1 {socket conflict} {stdio} {
- removeFile script
- set f [open script w]
- puts $f {
- set f [socket -server accept 2828]
- puts ready
- gets stdin
- close $f
- }
- close $f
- set f [open "|[list $tcltest script]" r+]
- gets $f
- set x [list [catch {socket -server accept 2828} msg] \
- $msg]
- puts $f bye
- close $f
- set x
-} {1 {couldn't open socket: address already in use}}
-test socket-3.2 {server with several clients} {stdio} {
- removeFile script
- set f [open script w]
- puts $f {
- set t1 [after 30000 "set x timed_out"]
- set t2 [after 31000 "set x timed_out"]
- set t3 [after 32000 "set x timed_out"]
- set counter 0
- set s [socket -server accept 2828]
- proc accept {s a p} {
- fileevent $s readable [list echo $s]
- fconfigure $s -buffering line
- }
- proc echo {s} {
- global x
- set l [gets $s]
- if {[eof $s]} {
- close $s
- set x done
- } else {
- puts $s $l
- }
- }
- puts ready
- vwait x
- after cancel $t1
- vwait x
- after cancel $t2
- vwait x
- after cancel $t3
- close $s
- puts $x
- }
- close $f
- set f [open "|[list $tcltest script]" r+]
- set x [gets $f]
- set s1 [socket localhost 2828]
- fconfigure $s1 -buffering line
- set s2 [socket localhost 2828]
- fconfigure $s2 -buffering line
- set s3 [socket localhost 2828]
- fconfigure $s3 -buffering line
- for {set i 0} {$i < 100} {incr i} {
- puts $s1 hello,s1
- gets $s1
- puts $s2 hello,s2
- gets $s2
- puts $s3 hello,s3
- gets $s3
- }
- close $s1
- close $s2
- close $s3
- lappend x [gets $f]
- close $f
- set x
-} {ready done}
-
-test socket-4.1 {server with several clients} {stdio} {
- removeFile script
- set f [open script w]
- puts $f {
- gets stdin
- set s [socket localhost 2828]
- fconfigure $s -buffering line
- for {set i 0} {$i < 100} {incr i} {
- puts $s hello
- gets $s
- }
- close $s
- puts bye
- gets stdin
- }
- close $f
- set p1 [open "|[list $tcltest script]" r+]
- fconfigure $p1 -buffering line
- set p2 [open "|[list $tcltest script]" r+]
- fconfigure $p2 -buffering line
- set p3 [open "|[list $tcltest script]" r+]
- fconfigure $p3 -buffering line
- proc accept {s a p} {
- fconfigure $s -buffering line
- fileevent $s readable [list echo $s]
- }
- proc echo {s} {
- global x
- set l [gets $s]
- if {[eof $s]} {
- close $s
- set x done
- } else {
- puts $s $l
- }
- }
- set t1 [after 30000 "set x timed_out"]
- set t2 [after 31000 "set x timed_out"]
- set t3 [after 32000 "set x timed_out"]
- set s [socket -server accept 2828]
- puts $p1 open
- puts $p2 open
- puts $p3 open
- vwait x
- vwait x
- vwait x
- after cancel $t1
- after cancel $t2
- after cancel $t3
- close $s
- set l ""
- lappend l [list p1 [gets $p1] $x]
- lappend l [list p2 [gets $p2] $x]
- lappend l [list p3 [gets $p3] $x]
- puts $p1 bye
- puts $p2 bye
- puts $p3 bye
- close $p1
- close $p2
- close $p3
- set l
-} {{p1 bye done} {p2 bye done} {p3 bye done}}
-test socket-4.2 {byte order problems, socket numbers, htons} {
- set x ok
- if {[catch {socket -server dodo 0x3000} msg]} {
- set x $msg
- } else {
- close $msg
- }
- set x
-} ok
-
-test socket-5.1 {byte order problems, socket numbers, htons} {unixOnly} {
- #
- # THIS TEST WILL FAIL if you are running as superuser.
- #
- set x {couldn't open socket: not owner}
- if {![catch {socket -server dodo 0x1} msg]} {
- set x {htons problem, should be disallowed, are you running as SU?}
- close $msg
- }
- set x
-} {couldn't open socket: not owner}
-test socket-5.2 {byte order problems, socket numbers, htons} {
- set x {couldn't open socket: port number too high}
- if {![catch {socket -server dodo 0x10000} msg]} {
- set x {port resolution problem, should be disallowed}
- close $msg
- }
- set x
-} {couldn't open socket: port number too high}
-test socket-5.3 {byte order problems, socket numbers, htons} {unixOnly} {
- #
- # THIS TEST WILL FAIL if you are running as superuser.
- #
- set x {couldn't open socket: not owner}
- if {![catch {socket -server dodo 21} msg]} {
- set x {htons problem, should be disallowed, are you running as SU?}
- close $msg
- }
- set x
-} {couldn't open socket: not owner}
-
-test socket-6.1 {accept callback error} {stdio} {
- removeFile script
- set f [open script w]
- puts $f {
- gets stdin
- socket localhost 2848
- }
- close $f
- set f [open "|[list $tcltest script]" r+]
- proc bgerror args {
- global x
- set x $args
- }
- proc accept {s a p} {expr 10 / 0}
- set s [socket -server accept 2848]
- puts $f hello
- close $f
- set timer [after 10000 "set x timed_out"]
- vwait x
- after cancel $timer
- close $s
- rename bgerror {}
- set x
-} {{divide by zero}}
-
-test socket-7.1 {testing socket specific options} {stdio} {
- removeFile script
- set f [open script w]
- puts $f {
- socket -server accept 2820
- proc accept args {
- global x
- set x done
- }
- puts ready
- set timer [after 10000 "set x timed_out"]
- vwait x
- after cancel $timer
- }
- close $f
- set f [open "|[list $tcltest script]" r]
- gets $f
- set s [socket localhost 2820]
- set p [fconfigure $s -peername]
- close $s
- close $f
- set l ""
- lappend l [string compare [lindex $p 0] 127.0.0.1]
- lappend l [string compare [lindex $p 2] 2820]
- lappend l [llength $p]
-} {0 0 3}
-test socket-7.2 {testing socket specific options} {stdio} {
- removeFile script
- set f [open script w]
- puts $f {
- socket -server accept 2821
- proc accept args {
- global x
- set x done
- }
- puts ready
- set timer [after 10000 "set x timed_out"]
- vwait x
- after cancel $timer
- }
- close $f
- set f [open "|[list $tcltest script]" r]
- gets $f
- set s [socket localhost 2821]
- set p [fconfigure $s -sockname]
- close $s
- close $f
- set l ""
- lappend l [llength $p]
- lappend l [lindex $p 0]
- lappend l [expr [lindex $p 2] == 2821]
-} {3 127.0.0.1 0}
-test socket-7.3 {testing socket specific options} {
- set s [socket -server accept 2822]
- set l [fconfigure $s]
- close $s
- update
- llength $l
-} 10
-test socket-7.4 {testing socket specific options} {
- set s [socket -server accept 2823]
- proc accept {s a p} {
- global x
- set x [fconfigure $s -sockname]
- close $s
- }
- set s1 [socket [info hostname] 2823]
- set timer [after 10000 "set x timed_out"]
- vwait x
- after cancel $timer
- close $s
- close $s1
- set l ""
- lappend l [lindex $x 2] [llength $x]
-} {2823 3}
-test socket-7.5 {testing socket specific options} {unixOrPc} {
- set s [socket -server accept 2829]
- proc accept {s a p} {
- global x
- set x [fconfigure $s -sockname]
- close $s
- }
- set s1 [socket localhost 2829]
- set timer [after 10000 "set x timed_out"]
- vwait x
- after cancel $timer
- close $s
- close $s1
- set l ""
- lappend l [lindex $x 0] [lindex $x 2] [llength $x]
-} {127.0.0.1 2829 3}
-
-test socket-8.1 {testing -async flag on sockets} {
- # NOTE: This test may fail on some Solaris 2.4 systems. If it does,
- # check that you have these patches installed (using showrev -p):
- #
- # 101907-05, 101925-02, 101945-14, 101959-03, 101969-05, 101973-03,
- # 101977-03, 101981-02, 101985-01, 102001-03, 102003-01, 102007-01,
- # 102011-02, 102024-01, 102039-01, 102044-01, 102048-01, 102062-03,
- # 102066-04, 102070-01, 102105-01, 102153-03, 102216-01, 102232-01,
- # 101878-03, 101879-01, 101880-03, 101933-01, 101950-01, 102030-01,
- # 102057-08, 102140-01, 101920-02, 101921-09, 101922-07, 101923-03
- #
- # If after installing these patches you are still experiencing a
- # problem, please email jyl@eng.sun.com. We have not observed this
- # failure on Solaris 2.5, so another option (instead of installing
- # these patches) is to upgrade to Solaris 2.5.
- set s [socket -server accept 2830]
- proc accept {s a p} {
- global x
- puts $s bye
- close $s
- set x done
- }
- set s1 [socket -async [info hostname] 2830]
- vwait x
- set z [gets $s1]
- close $s
- close $s1
- set z
-} bye
-
-test socket-9.1 {testing spurious events} {
- set len 0
- set spurious 0
- set done 0
- proc readlittle {s} {
- global spurious done len
- set l [read $s 1]
- if {[string length $l] == 0} {
- if {![eof $s]} {
- incr spurious
- } else {
- close $s
- set done 1
- }
- } else {
- incr len [string length $l]
- }
- }
- proc accept {s a p} {
- fconfigure $s -buffering none -blocking off
- fileevent $s readable [list readlittle $s]
- }
- set s [socket -server accept 2831]
- set c [socket [info hostname] 2831]
- puts -nonewline $c 01234567890123456789012345678901234567890123456789
- close $c
- set timer [after 10000 "set done timed_out"]
- vwait done
- after cancel $timer
- close $s
- list $spurious $len
-} {0 50}
-test socket-9.2 {testing async write, fileevents, flush on close} {} {
- set firstblock ""
- for {set i 0} {$i < 5} {incr i} {set firstblock "a$firstblock$firstblock"}
- set secondblock ""
- for {set i 0} {$i < 16} {incr i} {
- set secondblock "b$secondblock$secondblock"
- }
- set l [socket -server accept 2832]
- proc accept {s a p} {
- fconfigure $s -blocking 0 -translation lf -buffersize 16384 \
- -buffering line
- fileevent $s readable "readable $s"
- }
- proc readable {s} {
- set l [gets $s]
- fileevent $s readable {}
- after 1000 respond $s
- }
- proc respond {s} {
- global firstblock
- puts -nonewline $s $firstblock
- after 1000 writedata $s
- }
- proc writedata {s} {
- global secondblock
- puts -nonewline $s $secondblock
- close $s
- }
- set s [socket [info hostname] 2832]
- fconfigure $s -blocking 0 -trans lf -buffering line
- set count 0
- puts $s hello
- proc readit {s} {
- global count done
- set l [read $s]
- incr count [string length $l]
- if {[eof $s]} {
- close $s
- set done 1
- }
- }
- fileevent $s readable "readit $s"
- set timer [after 10000 "set done timed_out"]
- vwait done
- after cancel $timer
- close $l
- set count
-} 65566
-test socket-9.3 {testing EOF stickyness} {
- proc count_to_eof {s} {
- global count done timer
- set l [gets $s]
- if {[eof $s]} {
- incr count
- if {$count > 9} {
- close $s
- set done true
- set count {eof is sticky}
- after cancel $timer
- }
- }
- }
- proc timerproc {} {
- global done count c
- set done true
- set count {timer went off, eof is not sticky}
- close $c
- }
- set count 0
- set done false
- proc write_then_close {s} {
- puts $s bye
- close $s
- }
- proc accept {s a p} {
- fconfigure $s -buffering line -translation lf
- fileevent $s writable "write_then_close $s"
- }
- set s [socket -server accept 2833]
- set c [socket [info hostname] 2833]
- fconfigure $c -blocking off -buffering line -translation lf
- fileevent $c readable "count_to_eof $c"
- set timer [after 1000 timerproc]
- vwait done
- close $s
- set count
-} {eof is sticky}
-
-test socket-10.1 {testing socket accept callback error handling} {
- set goterror 0
- proc bgerror args {global goterror; set goterror 1}
- set s [socket -server accept 2898]
- proc accept {s a p} {close $s; error}
- set c [socket localhost 2898]
- vwait goterror
- close $s
- close $c
- set goterror
-} 1
-
-removeFile script
-
-#
-# The rest of the tests are run only if we are doing testing against
-# a remote server.
-#
-
-if {$doTestsWithRemoteServer == 0} {
- return
-}
-
-test socket-11.1 {tcp connection} {
- sendCommand {
- set socket9_1_test_server [socket -server accept 2834]
- proc accept {s a p} {
- puts $s done
- close $s
- }
- }
- set s [socket $remoteServerIP 2834]
- set r [gets $s]
- close $s
- sendCommand {close $socket9_1_test_server}
- set r
-} done
-test socket-11.2 {client specifies its port} {
- if {[info exists port]} {
- incr port
- } else {
- set port [expr 2048 + [pid]%1024]
- }
- sendCommand {
- set socket9_2_test_server [socket -server accept 2835]
- proc accept {s a p} {
- puts $s $p
- close $s
- }
- }
- set s [socket -myport $port $remoteServerIP 2835]
- set r [gets $s]
- close $s
- sendCommand {close $socket9_2_test_server}
- if {$r == $port} {
- set result ok
- } else {
- set result broken
- }
- set result
-} ok
-test socket-11.3 {trying to connect, no server} {
- set status ok
- if {![catch {set s [socket $remoteServerIp 2836]}]} {
- if {![catch {gets $s}]} {
- set status broken
- }
- close $s
- }
- set status
-} ok
-test socket-11.4 {remote echo, one line} {
- sendCommand {
- set socket10_6_test_server [socket -server accept 2836]
- proc accept {s a p} {
- fileevent $s readable [list echo $s]
- fconfigure $s -buffering line -translation crlf
- }
- proc echo {s} {
- set l [gets $s]
- if {[eof $s]} {
- close $s
- } else {
- puts $s $l
- }
- }
- }
- set f [socket $remoteServerIP 2836]
- fconfigure $f -translation crlf -buffering line
- puts $f hello
- set r [gets $f]
- close $f
- sendCommand {close $socket10_6_test_server}
- set r
-} hello
-test socket-11.5 {remote echo, 50 lines} {
- sendCommand {
- set socket10_7_test_server [socket -server accept 2836]
- proc accept {s a p} {
- fileevent $s readable [list echo $s]
- fconfigure $s -buffering line -translation crlf
- }
- proc echo {s} {
- set l [gets $s]
- if {[eof $s]} {
- close $s
- } else {
- puts $s $l
- }
- }
- }
- set f [socket $remoteServerIP 2836]
- fconfigure $f -translation crlf -buffering line
- for {set cnt 0} {$cnt < 50} {incr cnt} {
- puts $f "hello, $cnt"
- if {[string compare [gets $f] "hello, $cnt"] != 0} {
- break
- }
- }
- close $f
- sendCommand {close $socket10_7_test_server}
- set cnt
-} 50
-# Macintosh sockets can have more than one server per port
-if {$tcl_platform(platform) == "macintosh"} {
- set conflictResult {0 2836}
-} else {
- set conflictResult {1 {couldn't open socket: address already in use}}
-}
-test socket-11.6 {socket conflict} {
- set s1 [socket -server accept 2836]
- if {[catch {set s2 [socket -server accept 2836]} msg]} {
- set result [list 1 $msg]
- } else {
- set result [list 0 [lindex [fconfigure $s2 -sockname] 2]]
- close $s2
- }
- close $s1
- set result
-} $conflictResult
-test socket-11.7 {server with several clients} {
- sendCommand {
- set socket10_9_test_server [socket -server accept 2836]
- proc accept {s a p} {
- fconfigure $s -buffering line
- fileevent $s readable [list echo $s]
- }
- proc echo {s} {
- set l [gets $s]
- if {[eof $s]} {
- close $s
- } else {
- puts $s $l
- }
- }
- }
- set s1 [socket $remoteServerIP 2836]
- fconfigure $s1 -buffering line
- set s2 [socket $remoteServerIP 2836]
- fconfigure $s2 -buffering line
- set s3 [socket $remoteServerIP 2836]
- fconfigure $s3 -buffering line
- for {set i 0} {$i < 100} {incr i} {
- puts $s1 hello,s1
- gets $s1
- puts $s2 hello,s2
- gets $s2
- puts $s3 hello,s3
- gets $s3
- }
- close $s1
- close $s2
- close $s3
- sendCommand {close $socket10_9_test_server}
- set i
-} 100
-test socket-11.8 {client with several servers} {
- sendCommand {
- set s1 [socket -server "accept 4003" 4003]
- set s2 [socket -server "accept 4004" 4004]
- set s3 [socket -server "accept 4005" 4005]
- proc accept {mp s a p} {
- puts $s $mp
- close $s
- }
- }
- set s1 [socket $remoteServerIP 4003]
- set s2 [socket $remoteServerIP 4004]
- set s3 [socket $remoteServerIP 4005]
- set l ""
- lappend l [gets $s1] [gets $s1] [eof $s1] [gets $s2] [gets $s2] [eof $s2] \
- [gets $s3] [gets $s3] [eof $s3]
- close $s1
- close $s2
- close $s3
- sendCommand {
- close $s1
- close $s2
- close $s3
- }
- set l
-} {4003 {} 1 4004 {} 1 4005 {} 1}
-test socket-11.9 {accept callback error} {
- set s [socket -server accept 2836]
- proc accept {s a p} {expr 10 / 0}
- proc bgerror args {
- global x
- set x $args
- }
- if {[catch {sendCommand {
- set peername [fconfigure $callerSocket -peername]
- set s [socket [lindex $peername 0] 2836]
- close $s
- }} msg]} {
- close $s
- error $msg
- }
- set timer [after 10000 "set x timed_out"]
- vwait x
- after cancel $timer
- close $s
- rename bgerror {}
- set x
-} {{divide by zero}}
-test socket-11.10 {testing socket specific options} {
- sendCommand {
- set socket10_12_test_server [socket -server accept 2836]
- proc accept {s a p} {close $s}
- }
- set s [socket $remoteServerIP 2836]
- set p [fconfigure $s -peername]
- set n [fconfigure $s -sockname]
- set l ""
- lappend l [lindex $p 2] [llength $p] [llength $p]
- close $s
- sendCommand {close $socket10_12_test_server}
- set l
-} {2836 3 3}
-test socket-11.11 {testing spurious events} {
- sendCommand {
- set socket10_13_test_server [socket -server accept 2836]
- proc accept {s a p} {
- fconfigure $s -translation "auto lf"
- after 100 writesome $s
- }
- proc writesome {s} {
- for {set i 0} {$i < 100} {incr i} {
- puts $s "line $i from remote server"
- }
- close $s
- }
- }
- set len 0
- set spurious 0
- set done 0
- proc readlittle {s} {
- global spurious done len
- set l [read $s 1]
- if {[string length $l] == 0} {
- if {![eof $s]} {
- incr spurious
- } else {
- close $s
- set done 1
- }
- } else {
- incr len [string length $l]
- }
- }
- set c [socket $remoteServerIP 2836]
- fileevent $c readable "readlittle $c"
- set timer [after 10000 "set done timed_out"]
- vwait done
- after cancel $timer
- sendCommand {close $socket10_13_test_server}
- list $spurious $len
-} {0 2690}
-test socket-11.12 {testing EOF stickyness} {
- set counter 0
- set done 0
- proc count_up {s} {
- global counter done after_id
- set l [gets $s]
- if {[eof $s]} {
- incr counter
- if {$counter > 9} {
- set done {EOF is sticky}
- after cancel $after_id
- close $s
- }
- }
- }
- proc timed_out {} {
- global c done
- set done {timed_out, EOF is not sticky}
- close $c
- }
- sendCommand {
- set socket10_14_test_server [socket -server accept 2836]
- proc accept {s a p} {
- after 100 close $s
- }
- }
- set c [socket $remoteServerIP 2836]
- fileevent $c readable "count_up $c"
- set after_id [after 1000 timed_out]
- vwait done
- sendCommand {close $socket10_14_test_server}
- set done
-} {EOF is sticky}
-test socket-11.13 {testing async write, async flush, async close} {
- proc readit {s} {
- global count done
- set l [read $s]
- incr count [string length $l]
- if {[eof $s]} {
- close $s
- set done 1
- }
- }
- sendCommand {
- set firstblock ""
- for {set i 0} {$i < 5} {incr i} {
- set firstblock "a$firstblock$firstblock"
- }
- set secondblock ""
- for {set i 0} {$i < 16} {incr i} {
- set secondblock "b$secondblock$secondblock"
- }
- set l [socket -server accept 2845]
- proc accept {s a p} {
- fconfigure $s -blocking 0 -translation lf -buffersize 16384 \
- -buffering line
- fileevent $s readable "readable $s"
- }
- proc readable {s} {
- set l [gets $s]
- fileevent $s readable {}
- after 1000 respond $s
- }
- proc respond {s} {
- global firstblock
- puts -nonewline $s $firstblock
- after 1000 writedata $s
- }
- proc writedata {s} {
- global secondblock
- puts -nonewline $s $secondblock
- close $s
- }
- }
- set s [socket $remoteServerIP 2845]
- fconfigure $s -blocking 0 -trans lf -buffering line
- set count 0
- puts $s hello
- fileevent $s readable "readit $s"
- set timer [after 10000 "set done timed_out"]
- vwait done
- after cancel $timer
- sendCommand {close $l}
- set count
-} 65566
-
-test socket-12.1 {testing inheritance of server sockets} {
- removeFile script1
- removeFile script2
-
- # Script1 is just a 10 second delay. If the server socket
- # is inherited, it will be held open for 10 seconds
-
- set f [open script1 w]
- puts $f {
- after 10000 exit
- vwait forever
- }
- close $f
-
- # Script2 creates the server socket, launches script1,
- # waits a second, and exits. The server socket will now
- # be closed unless script1 inherited it.
-
- set f [open script2 w]
- puts $f [list set tcltest $tcltest]
- puts $f {
- set f [socket -server accept 2828]
- proc accept { file addr port } {
- close $file
- }
- exec $tcltest script1 &
- close $f
- after 1000 exit
- vwait forever
- }
- close $f
-
- # Launch script2 and wait 5 seconds
-
- exec $tcltest script2 &
- after 5000 { set ok_to_proceed 1 }
- vwait ok_to_proceed
-
- # If we can still connect to the server, the socket got inherited.
-
- if {[catch {socket localhost 2828} msg]} {
- set x {server socket was not inherited}
- } else {
- close $msg
- set x {server socket was inherited}
- }
-
- removeFile script1
- removeFile script2
- set x
-} {server socket was not inherited}
-test socket-12.2 {testing inheritance of client sockets} {
- removeFile script1
- removeFile script2
-
- # Script1 is just a 10 second delay. If the server socket
- # is inherited, it will be held open for 10 seconds
-
- set f [open script1 w]
- puts $f {
- after 10000 exit
- vwait forever
- }
- close $f
-
- # Script2 opens the client socket and writes to it. It then
- # launches script1 and exits. If the child process inherited the
- # client socket, the socket will still be open.
-
- set f [open script2 w]
- puts $f [list set tcltest $tcltest]
- puts $f {
- set f [socket localhost 2829]
- exec $tcltest script1 &
- puts $f testing
- flush $f
- after 1000 exit
- vwait forever
- }
- close $f
-
- # Create the server socket
-
- set server [socket -server accept 2829]
- proc accept { file host port } {
-
- # When the client connects, establish the read handler
- global server
- close $server
- fileevent $file readable [list getdata $file]
- fconfigure $file -buffering line -blocking 0
- return
- }
- proc getdata { file } {
-
- # Read handler on the accepted socket.
- global x
- global failed
- set status [catch {read $file} data]
- if {$status != 0} {
- set x {read failed, error was $data}
- catch { close $file }
- } elseif {[string compare {} $data]} {
- } elseif {[fblocked $file]} {
- } elseif {[eof $file]} {
- if {$failed} {
- set x {client socket was inherited}
- } else {
- set x {client socket was not inherited}
- }
- catch { close $file }
- } else {
- set x {impossible case}
- catch { close $file }
- }
- return
- }
-
- # If the socket doesn't hit end-of-file in 5 seconds, the
- # script1 process must have inherited the client.
-
- set failed 0
- after 5000 [list set failed 1]
-
- # Launch the script2 process
-
- exec $tcltest script2 &
-
- vwait x
- if {!$failed} {
- vwait failed
- }
- removeFile script1
- removeFile script2
- set x
-} {client socket was not inherited}
-test socket-12.3 {testing inheritance of accepted sockets} {
- removeFile script1
- removeFile script2
-
- set f [open script1 w]
- puts $f {
- after 10000 exit
- vwait forever
- }
- close $f
-
- set f [open script2 w]
- puts $f [list set tcltest $tcltest]
- puts $f {
- set server [socket -server accept 2930]
- proc accept { file host port } {
- global tcltest
- puts $file {test data on socket}
- exec $tcltest script1 &
- after 1000 exit
- }
- vwait forever
- }
- close $f
-
- # Launch the script2 process and connect to it. See how long
- # the socket stays open
-
- exec $tcltest script2 &
-
- after 1000 set ok_to_proceed 1
- vwait ok_to_proceed
-
- set f [socket localhost 2930]
- fconfigure $f -buffering full -blocking 0
- fileevent $f readable [list getdata $f]
-
- # If the socket is still open after 5 seconds, the script1 process
- # must have inherited the accepted socket.
-
- set failed 0
- after 5000 set failed 1
-
- proc getdata { file } {
-
- # Read handler on the client socket.
- global x
- global failed
- set status [catch {read $file} data]
- if {$status != 0} {
- set x {read failed, error was $data}
- catch { close $file }
- } elseif {[string compare {} $data]} {
- } elseif {[fblocked $file]} {
- } elseif {[eof $file]} {
- if {$failed} {
- set x {accepted socket was inherited}
- } else {
- set x {accepted socket was not inherited}
- }
- catch { close $file }
- } else {
- set x {impossible case}
- catch { close $file }
- }
- return
- }
-
- vwait x
-
- removeFile script1
- removeFile script2
- set x
-} {accepted socket was not inherited}
-
-
-if {[string match sock* $commandSocket] == 1} {
- puts $commandSocket exit
- flush $commandSocket
-}
-catch {close $commandSocket}
-catch {close $remoteProcChan}
-
-set x ""
-unset x
generated by cgit v0.12 at 2024-11-24 10:12:25 (GMT)