开通博客赚积分
发布资源赚积分
分类

源码开发语言/平台
当前位置：首页 > 源码/资料 > Windows编程 > 通讯编程 > 查看源码
socket.test
资源名称：ns-allinone-2.33.tar.gz　[点击查看]
上传用户：rrhhcc
上传日期：2015-12-11
资源大小：54129k
文件大小：44k
源码类别：

通讯编程

开发平台：

Visual C++

socket.test：源码内容
  1. # Commands tested in this file: socket.
  2. #
  3. # This file contains a collection of tests for one or more of the Tcl
  4. # built-in commands.  Sourcing this file into Tcl runs the tests and
  5. # generates output for errors.  No output means no errors were found.
  6. #
  7. # Copyright (c) 1994-1996 Sun Microsystems, Inc.
  8. # Copyright (c) 1998-2000 Ajuba Solutions.
  9. #
  10. # See the file "license.terms" for information on usage and redistribution
  11. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  12. #
  13. # RCS: @(#) $Id: socket.test,v 1.26.2.6 2006/03/16 00:35:59 andreas_kupries Exp $
  15. # Running socket tests with a remote server:
  16. # ------------------------------------------
  17. # 
  18. # Some tests in socket.test depend on the existence of a remote server to
  19. # which they connect. The remote server must be an instance of tcltest and it
  20. # must run the script found in the file "remote.tcl" in this directory. You
  21. # can start the remote server on any machine reachable from the machine on
  22. # which you want to run the socket tests, by issuing:
  23. # 
  24. #     tcltest remote.tcl -port 2048 # Or choose another port number.
  25. # 
  26. # If the machine you are running the remote server on has several IP
  27. # interfaces, you can choose which interface the server listens on for
  28. # connections by specifying the -address command line flag, so:
  29. # 
  30. #     tcltest remote.tcl -address your.machine.com
  31. # 
  32. # These options can also be set by environment variables. On Unix, you can
  33. # type these commands to the shell from which the remote server is started:
  34. # 
  35. #     shell% setenv serverPort 2048
  36. #     shell% setenv serverAddress your.machine.com
  37. # 
  38. # and subsequently you can start the remote server with:
  39. # 
  40. #     tcltest remote.tcl
  41. # 
  42. # to have it listen on port 2048 on the interface your.machine.com.
  43. #     
  44. # When the server starts, it prints out a detailed message containing its
  45. # configuration information, and it will block until killed with a Ctrl-C.
  46. # Once the remote server exists, you can run the tests in socket.test with
  47. # the server by setting two Tcl variables:
  48. # 
  49. #     % set remoteServerIP <name or address of machine on which server runs>
  50. #     % set remoteServerPort 2048
  51. # 
  52. # These variables are also settable from the environment. On Unix, you can:
  53. # 
  54. #     shell% setenv remoteServerIP machine.where.server.runs
  55. #     shell% senetv remoteServerPort 2048
  56. # 
  57. # The preamble of the socket.test file checks to see if the variables are set
  58. # either in Tcl or in the environment; if they are, it attempts to connect to
  59. # the server. If the connection is successful, the tests using the remote
  60. # server will be performed; otherwise, it will attempt to start the remote
  61. # server (via exec) on platforms that support this, on the local host,
  62. # listening at port 2048. If all fails, a message is printed and the tests
  63. # using the remote server are not performed.
  65. package require tcltest 2
  66. namespace import -force ::tcltest::*
  68. # Some tests require the testthread and exec commands
  69. testConstraint testthread [llength [info commands testthread]]
  70. testConstraint exec [llength [info commands exec]]
  72. # If remoteServerIP or remoteServerPort are not set, check in the
  73. # environment variables for externally set values.
  74. #
  76. if {![info exists remoteServerIP]} {
  77.     if {[info exists env(remoteServerIP)]} {
  78. set remoteServerIP $env(remoteServerIP)
  79.     }
  80. }
  81. if {![info exists remoteServerPort]} {
  82.     if {[info exists env(remoteServerIP)]} {
  83. set remoteServerPort $env(remoteServerPort)
  84.     } else {
  85.         if {[info exists remoteServerIP]} {
  86.     set remoteServerPort 2048
  87.         }
  88.     }
  89. }
  91. #
  92. # Check if we're supposed to do tests against the remote server
  93. #
  95. set doTestsWithRemoteServer 1
  96. if {![info exists remoteServerIP] && ($tcl_platform(platform) != "macintosh")} {
  97.     set remoteServerIP 127.0.0.1
  98. }
  99. if {($doTestsWithRemoteServer == 1) && (![info exists remoteServerPort])} {
  100.     set remoteServerPort 2048
  101. }
  103. # Attempt to connect to a remote server if one is already running. If it
  104. # is not running or for some other reason the connect fails, attempt to
  105. # start the remote server on the local host listening on port 2048. This
  106. # is only done on platforms that support exec (i.e. not on the Mac). On
  107. # platforms that do not support exec, the remote server must be started
  108. # by the user before running the tests.
  110. set remoteProcChan ""
  111. set commandSocket ""
  112. if {$doTestsWithRemoteServer} {
  113.     catch {close $commandSocket}
  114.     if {[catch {set commandSocket [socket $remoteServerIP 
  115. $remoteServerPort]}] != 0} {
  116. if {[info commands exec] == ""} {
  117.     set noRemoteTestReason "can't exec"
  118.     set doTestsWithRemoteServer 0
  119. } else {
  120.     set remoteServerIP 127.0.0.1
  121.     # Be *extra* careful in case this file is sourced from
  122.     # a directory other than the current one...
  123.     set remoteFile [file join [pwd] [file dirname [info script]] 
  124.     remote.tcl]
  125.     if {[catch {set remoteProcChan 
  126. [open "|[list [interpreter] $remoteFile 
  127. -serverIsSilent 
  128. -port $remoteServerPort 
  129. -address $remoteServerIP]" 
  130. w+]} 
  131.    msg] == 0} {
  132. after 1000
  133. if {[catch {set commandSocket [socket $remoteServerIP 
  134. $remoteServerPort]} msg] == 0} {
  135.     fconfigure $commandSocket -translation crlf -buffering line
  136. } else {
  137.     set noRemoteTestReason $msg
  138.     set doTestsWithRemoteServer 0
  139. }
  140.     } else {
  141. set noRemoteTestReason "$msg [interpreter]"
  142. set doTestsWithRemoteServer 0
  143.     }
  144. }
  145.     } else {
  146. fconfigure $commandSocket -translation crlf -buffering line
  147.     }
  148. }
  150. # Some tests are run only if we are doing testing against a remote server.
  151. set ::tcltest::testConstraints(doTestsWithRemoteServer) $doTestsWithRemoteServer
  152. if {$doTestsWithRemoteServer == 0} {
  153.     if {[string first s $::tcltest::verbose] != -1} {
  154.      puts "Skipping tests with remote server. See tests/socket.test for"
  155. puts "information on how to run remote server."
  156. puts "Reason for not doing remote tests: $noRemoteTestReason"
  157.     }
  158. }
  160. #
  161. # If we do the tests, define a command to send a command to the
  162. # remote server.
  163. #
  165. if {$doTestsWithRemoteServer == 1} {
  166.     proc sendCommand {c} {
  167. global commandSocket
  169. if {[eof $commandSocket]} {
  170.     error "remote server disappeared"
  171. }
  173. if {[catch {puts $commandSocket $c} msg]} {
  174.     error "remote server disappaered: $msg"
  175. }
  176. if {[catch {puts $commandSocket "--Marker--Marker--Marker--"} msg]} {
  177.     error "remote server disappeared: $msg"
  178. }
  180. set resp ""
  181. while {1} {
  182.     set line [gets $commandSocket]
  183.     if {[eof $commandSocket]} {
  184. error "remote server disappaered"
  185.     }
  186.     if {[string compare $line "--Marker--Marker--Marker--"] == 0} {
  187. if {[string compare [lindex $resp 0] error] == 0} {
  188.     error [lindex $resp 1]
  189. } else {
  190.     return [lindex $resp 1]
  191. }
  192.     } else {
  193. append resp $line "n"
  194.     }
  195. }
  196.     }
  197. }
  199. test socket-1.1 {arg parsing for socket command} {socket} {
  200.     list [catch {socket -server} msg] $msg
  201. } {1 {no argument given for -server option}}
  202. test socket-1.2 {arg parsing for socket command} {socket} {
  203.     list [catch {socket -server foo} msg] $msg
  204. } {1 {wrong # args: should be either:
  205. socket ?-myaddr addr? ?-myport myport? ?-async? host port
  206. socket -server command ?-myaddr addr? port}}
  207. test socket-1.3 {arg parsing for socket command} {socket} {
  208.     list [catch {socket -myaddr} msg] $msg
  209. } {1 {no argument given for -myaddr option}}
  210. test socket-1.4 {arg parsing for socket command} {socket} {
  211.     list [catch {socket -myaddr 127.0.0.1} msg] $msg
  212. } {1 {wrong # args: should be either:
  213. socket ?-myaddr addr? ?-myport myport? ?-async? host port
  214. socket -server command ?-myaddr addr? port}}
  215. test socket-1.5 {arg parsing for socket command} {socket} {
  216.     list [catch {socket -myport} msg] $msg
  217. } {1 {no argument given for -myport option}}
  218. test socket-1.6 {arg parsing for socket command} {socket} {
  219.     list [catch {socket -myport xxxx} msg] $msg
  220. } {1 {expected integer but got "xxxx"}}
  221. test socket-1.7 {arg parsing for socket command} {socket} {
  222.     list [catch {socket -myport 2522} msg] $msg
  223. } {1 {wrong # args: should be either:
  224. socket ?-myaddr addr? ?-myport myport? ?-async? host port
  225. socket -server command ?-myaddr addr? port}}
  226. test socket-1.8 {arg parsing for socket command} {socket} {
  227.     list [catch {socket -froboz} msg] $msg
  228. } {1 {bad option "-froboz": must be -async, -myaddr, -myport, or -server}}
  229. test socket-1.9 {arg parsing for socket command} {socket} {
  230.     list [catch {socket -server foo -myport 2521 3333} msg] $msg
  231. } {1 {Option -myport is not valid for servers}}
  232. test socket-1.10 {arg parsing for socket command} {socket} {
  233.     list [catch {socket host 2528 -junk} msg] $msg
  234. } {1 {wrong # args: should be either:
  235. socket ?-myaddr addr? ?-myport myport? ?-async? host port
  236. socket -server command ?-myaddr addr? port}}
  237. test socket-1.11 {arg parsing for socket command} {socket} {
  238.     list [catch {socket -server callback 2520 --} msg] $msg
  239. } {1 {wrong # args: should be either:
  240. socket ?-myaddr addr? ?-myport myport? ?-async? host port
  241. socket -server command ?-myaddr addr? port}}
  242. test socket-1.12 {arg parsing for socket command} {socket} {
  243.     list [catch {socket foo badport} msg] $msg
  244. } {1 {expected integer but got "badport"}}
  245. test socket-1.13 {arg parsing for socket command} {socket} {
  246. list [catch {socket -async -server} msg] $msg
  247. } {1 {cannot set -async option for server sockets}}
  248. test socket-1.14 {arg parsing for socket command} {socket} {
  249. list [catch {socket -server foo -async} msg] $msg
  250. } {1 {cannot set -async option for server sockets}}
  252. set path(script) [makeFile {} script]
  254. test socket-2.1 {tcp connection} {socket stdio} {
  255.     file delete $path(script)
  256.     set f [open $path(script) w]
  257.     puts $f {
  258. set timer [after 10000 "set x timed_out"]
  259. set f [socket -server accept 0]
  260. proc accept {file addr port} {
  261.     global x
  262.     set x done
  263.             close $file
  264. }
  265. puts ready
  266. puts [lindex [fconfigure $f -sockname] 2]
  267. vwait x
  268. after cancel $timer
  269. close $f
  270. puts $x
  271.     }
  272.     close $f
  273.     set f [open "|[list [interpreter] $path(script)]" r]
  274.     gets $f x
  275.     gets $f listen
  276.     if {[catch {socket 127.0.0.1 $listen} msg]} {
  277.         set x $msg
  278.     } else {
  279.         lappend x [gets $f]
  280.         close $msg
  281.     }
  282.     lappend x [gets $f]
  283.     close $f
  284.     set x
  285. } {ready done {}}
  287. if [info exists port] {
  288.     incr port
  289. } else { 
  290.     set port [expr 2048 + [pid]%1024]
  291. }
  292. test socket-2.2 {tcp connection with client port specified} {socket stdio} {
  293.     file delete $path(script)
  294.     set f [open $path(script) w]
  295.     puts $f {
  296. set timer [after 10000 "set x timeout"]
  297.         set f [socket -server accept 0]
  298. proc accept {file addr port} {
  299.             global x
  300.             puts "[gets $file] $port"
  301.             close $file
  302.             set x done
  303. }
  304. puts ready
  305. puts [lindex [fconfigure $f -sockname] 2]
  306. vwait x
  307. after cancel $timer
  308. close $f
  309.     }
  310.     close $f
  311.     set f [open "|[list [interpreter] $path(script)]" r]
  312.     gets $f x
  313.     gets $f listen
  314.     global port
  315.     if {[catch {socket -myport $port 127.0.0.1 $listen} sock]} {
  316.         set x $sock
  317. close [socket 127.0.0.1 $listen]
  318. puts stderr $sock
  319.     } else {
  320.         puts $sock hello
  321. flush $sock
  322.         lappend x [gets $f]
  323.         close $sock
  324.     }
  325.     close $f
  326.     set x
  327. } [list ready "hello $port"]
  328. test socket-2.3 {tcp connection with client interface specified} {socket stdio} {
  329.     file delete $path(script)
  330.     set f [open $path(script) w]
  331.     puts $f {
  332. set timer [after 2000 "set x done"]
  333.         set f [socket  -server accept 2830]
  334. proc accept {file addr port} {
  335.             global x
  336.             puts "[gets $file] $addr"
  337.             close $file
  338.             set x done
  339. }
  340. puts ready
  341. vwait x
  342. after cancel $timer
  343. close $f
  344.     }
  345.     close $f
  346.     set f [open "|[list [interpreter] $path(script)]" r]
  347.     gets $f x
  348.     if {[catch {socket -myaddr 127.0.0.1 127.0.0.1 2830} sock]} {
  349.         set x $sock
  350.     } else {
  351.         puts $sock hello
  352. flush $sock
  353.         lappend x [gets $f]
  354.         close $sock
  355.     }
  356.     close $f
  357.     set x
  358. } {ready {hello 127.0.0.1}}
  359. test socket-2.4 {tcp connection with server interface specified} {socket stdio} {
  360.     file delete $path(script)
  361.     set f [open $path(script) w]
  362.     puts $f {
  363. set timer [after 2000 "set x done"]
  364.         set f [socket -server accept -myaddr 127.0.0.1 0]
  365. proc accept {file addr port} {
  366.             global x
  367.             puts "[gets $file]"
  368.             close $file
  369.             set x done
  370. }
  371. puts ready
  372. puts [lindex [fconfigure $f -sockname] 2]
  373. vwait x
  374. after cancel $timer
  375. close $f
  376.     }
  377.     close $f
  378.     set f [open "|[list [interpreter] $path(script)]" r]
  379.     gets $f x
  380.     gets $f listen
  381.     if {[catch {socket 127.0.0.1 $listen} sock]} {
  382.         set x $sock
  383.     } else {
  384.         puts $sock hello
  385. flush $sock
  386.         lappend x [gets $f]
  387.         close $sock
  388.     }
  389.     close $f
  390.     set x
  391. } {ready hello}
  392. test socket-2.5 {tcp connection with redundant server port} {socket stdio} {
  393.     file delete $path(script)
  394.     set f [open $path(script) w]
  395.     puts $f {
  396. set timer [after 10000 "set x timeout"]
  397.         set f [socket -server accept 0]
  398. proc accept {file addr port} {
  399.             global x
  400.             puts "[gets $file]"
  401.             close $file
  402.             set x done
  403. }
  404. puts ready
  405. puts [lindex [fconfigure $f -sockname] 2]
  406. vwait x
  407. after cancel $timer
  408. close $f
  409.     }
  410.     close $f
  411.     set f [open "|[list [interpreter] $path(script)]" r]
  412.     gets $f x
  413.     gets $f listen
  414.     if {[catch {socket 127.0.0.1 $listen} sock]} {
  415.         set x $sock
  416.     } else {
  417.         puts $sock hello
  418. flush $sock
  419.         lappend x [gets $f]
  420.         close $sock
  421.     }
  422.     close $f
  423.     set x
  424. } {ready hello}
  425. test socket-2.6 {tcp connection} {socket} {
  426.     set status ok
  427.     if {![catch {set sock [socket 127.0.0.1 2833]}]} {
  428. if {![catch {gets $sock}]} {
  429.     set status broken
  430. }
  431. close $sock
  432.     }
  433.     set status
  434. } ok
  435. test socket-2.7 {echo server, one line} {socket stdio} {
  436.     file delete $path(script)
  437.     set f [open $path(script) w]
  438.     puts $f {
  439. set timer [after 10000 "set x timeout"]
  440. set f [socket -server accept 0]
  441. proc accept {s a p} {
  442.             fileevent $s readable [list echo $s]
  443.     fconfigure $s -translation lf -buffering line
  444.         }
  445. proc echo {s} {
  446.      set l [gets $s]
  447.              if {[eof $s]} {
  448.                  global x
  449.                  close $s
  450.                  set x done
  451.              } else {
  452.                  puts $s $l
  453.              }
  454. }
  455. puts ready
  456. puts [lindex [fconfigure $f -sockname] 2]
  457. vwait x
  458. after cancel $timer
  459. close $f
  460. puts $x
  461.     }
  462.     close $f
  463.     set f [open "|[list [interpreter] $path(script)]" r]
  464.     gets $f
  465.     gets $f listen
  466.     set s [socket 127.0.0.1 $listen]
  467.     fconfigure $s -buffering line -translation lf
  468.     puts $s "hello abcdefghijklmnop"
  469.     after 1000
  470.     set x [gets $s]
  471.     close $s
  472.     set y [gets $f]
  473.     close $f
  474.     list $x $y
  475. } {{hello abcdefghijklmnop} done}
  476. removeFile script
  477. test socket-2.8 {echo server, loop 50 times, single connection} -constraints {socket stdio} -setup {
  478.     set path(script) [makeFile {
  479. set f [socket -server accept 0]
  480. proc accept {s a p} {
  481.             fileevent $s readable [list echo $s]
  482.             fconfigure $s -buffering line
  483.         }
  484. proc echo {s} {
  485.      global i
  486.              set l [gets $s]
  487.              if {[eof $s]} {
  488.                  global x
  489.                  close $s
  490.                  set x done
  491.              } else { 
  492.          incr i
  493.                  puts $s $l
  494.              }
  495. }
  496. set i 0
  497. puts ready
  498. puts [lindex [fconfigure $f -sockname] 2]
  499. set timer [after 20000 "set x done"]
  500. vwait x
  501. after cancel $timer
  502. close $f
  503. puts "done $i"
  504.     } script]
  505. } -body {
  506.     set f [open "|[list [interpreter] $path(script)]" r]
  507.     gets $f
  508.     gets $f listen
  509.     set s [socket 127.0.0.1 $listen]
  510.     fconfigure $s -buffering line
  511.     catch {
  512. for {set x 0} {$x < 50} {incr x} {
  513.     puts $s "hello abcdefghijklmnop"
  514.     gets $s
  515. }
  516.     }
  517.     close $s
  518.     catch {set x [gets $f]}
  519.     close $f
  520.     set x
  521. } -cleanup {
  522.     removeFile script
  523. } -result {done 50}
  524. set path(script) [makeFile {} script]
  525. test socket-2.9 {socket conflict} {socket stdio} {
  526.     set s [socket -server accept 0]
  527.     file delete $path(script)
  528.     set f [open $path(script) w]
  529.     puts -nonewline $f "socket -server accept [lindex [fconfigure $s -sockname] 2]"
  530.     close $f
  531.     set f [open "|[list [interpreter] $path(script)]" r]
  532.     gets $f
  533.     after 100
  534.     set x [list [catch {close $f} msg]]
  535.     regsub "n.*$" $msg {} msg ; # cut part of the error message containing the port number
  536.     lappend x $msg
  537.     close $s
  538.     set x
  539. } {1 {couldn't open socket: address already in use}}
  540. test socket-2.10 {close on accept, accepted socket lives} {socket} {
  541.     set done 0
  542.     set timer [after 20000 "set done timed_out"]
  543.     set ss [socket -server accept 0]
  544.     proc accept {s a p} {
  545. global ss
  546. close $ss
  547. fileevent $s readable "readit $s"
  548. fconfigure $s -trans lf
  549.     }
  550.     proc readit {s} {
  551. global done
  552. gets $s
  553. close $s
  554. set done 1
  555.     }
  556.     set cs [socket [info hostname] [lindex [fconfigure $ss -sockname] 2]]
  557.     puts $cs hello
  558.     close $cs
  559.     vwait done
  560.     after cancel $timer
  561.     set done
  562. } 1
  563. test socket-2.11 {detecting new data} {socket} {
  564.     proc accept {s a p} {
  565. global sock
  566. set sock $s
  567.     }
  569.     set s [socket -server accept 0]
  570.     set sock ""
  571.     set s2 [socket 127.0.0.1 [lindex [fconfigure $s -sockname] 2]]
  572.     vwait sock
  573.     puts $s2 one
  574.     flush $s2
  575.     after 500
  576.     fconfigure $sock -blocking 0
  577.     set result a:[gets $sock]
  578.     lappend result b:[gets $sock]
  579.     fconfigure $sock -blocking 1
  580.     puts $s2 two
  581.     flush $s2
  582.     fconfigure $sock -blocking 0
  583.     lappend result c:[gets $sock]
  584.     fconfigure $sock -blocking 1
  585.     close $s2
  586.     close $s
  587.     close $sock
  588.     set result
  589. } {a:one b: c:two}
  592. test socket-3.1 {socket conflict} {socket stdio} {
  593.     file delete $path(script)
  594.     set f [open $path(script) w]
  595.     puts $f {
  596. set f [socket -server accept 0]
  597. puts ready
  598. puts [lindex [fconfigure $f -sockname] 2]
  599. gets stdin
  600. close $f
  601.     }
  602.     close $f
  603.     set f [open "|[list [interpreter] $path(script)]" r+]
  604.     gets $f
  605.     gets $f listen
  606.     set x [list [catch {socket -server accept $listen} msg] 
  607. $msg]
  608.     puts $f bye
  609.     close $f
  610.     set x
  611. } {1 {couldn't open socket: address already in use}}
  612. test socket-3.2 {server with several clients} {socket stdio} {
  613.     file delete $path(script)
  614.     set f [open $path(script) w]
  615.     puts $f {
  616. set t1 [after 30000 "set x timed_out"]
  617. set t2 [after 31000 "set x timed_out"]
  618. set t3 [after 32000 "set x timed_out"]
  619. set counter 0
  620. set s [socket -server accept 0]
  621. proc accept {s a p} {
  622.     fileevent $s readable [list echo $s]
  623.     fconfigure $s -buffering line
  624. }
  625. proc echo {s} {
  626.      global x
  627.              set l [gets $s]
  628.              if {[eof $s]} {
  629.                  close $s
  630.                  set x done
  631.              } else {
  632.                  puts $s $l
  633.              }
  634. }
  635. puts ready
  636. puts [lindex [fconfigure $s -sockname] 2]
  637. vwait x
  638. after cancel $t1
  639. vwait x
  640. after cancel $t2
  641. vwait x
  642. after cancel $t3
  643. close $s
  644. puts $x
  645.     }
  646.     close $f
  647.     set f [open "|[list [interpreter] $path(script)]" r+]
  648.     set x [gets $f]
  649.     gets $f listen
  650.     set s1 [socket 127.0.0.1 $listen]
  651.     fconfigure $s1 -buffering line
  652.     set s2 [socket 127.0.0.1 $listen]
  653.     fconfigure $s2 -buffering line
  654.     set s3 [socket 127.0.0.1 $listen]
  655.     fconfigure $s3 -buffering line
  656.     for {set i 0} {$i < 100} {incr i} {
  657. puts $s1 hello,s1
  658. gets $s1
  659. puts $s2 hello,s2
  660. gets $s2
  661. puts $s3 hello,s3
  662. gets $s3
  663.     }
  664.     close $s1
  665.     close $s2
  666.     close $s3
  667.     lappend x [gets $f]
  668.     close $f
  669.     set x
  670. } {ready done}
  672. test socket-4.1 {server with several clients} {socket stdio} {
  673.     file delete $path(script)
  674.     set f [open $path(script) w]
  675.     puts $f {
  676. set port [gets stdin]
  677. set s [socket 127.0.0.1 $port]
  678. fconfigure $s -buffering line
  679. for {set i 0} {$i < 100} {incr i} {
  680.     puts $s hello
  681.     gets $s
  682. }
  683. close $s
  684. puts bye
  685. gets stdin
  686.     }
  687.     close $f
  688.     set p1 [open "|[list [interpreter] $path(script)]" r+]
  689.     fconfigure $p1 -buffering line
  690.     set p2 [open "|[list [interpreter] $path(script)]" r+]
  691.     fconfigure $p2 -buffering line
  692.     set p3 [open "|[list [interpreter] $path(script)]" r+]
  693.     fconfigure $p3 -buffering line
  694.     proc accept {s a p} {
  695. fconfigure $s -buffering line
  696. fileevent $s readable [list echo $s]
  697.     }
  698.     proc echo {s} {
  699. global x
  700.         set l [gets $s]
  701.         if {[eof $s]} {
  702.             close $s
  703.             set x done
  704.         } else {
  705.             puts $s $l
  706.         }
  707.     }
  708.     set t1 [after 30000 "set x timed_out"]
  709.     set t2 [after 31000 "set x timed_out"]
  710.     set t3 [after 32000 "set x timed_out"]
  711.     set s [socket -server accept 0]
  712.     set listen [lindex [fconfigure $s -sockname] 2]
  713.     puts $p1 $listen
  714.     puts $p2 $listen
  715.     puts $p3 $listen
  716.     vwait x
  717.     vwait x
  718.     vwait x
  719.     after cancel $t1
  720.     after cancel $t2
  721.     after cancel $t3
  722.     close $s
  723.     set l ""
  724.     lappend l [list p1 [gets $p1] $x]
  725.     lappend l [list p2 [gets $p2] $x]
  726.     lappend l [list p3 [gets $p3] $x]
  727.     puts $p1 bye
  728.     puts $p2 bye
  729.     puts $p3 bye
  730.     close $p1
  731.     close $p2
  732.     close $p3
  733.     set l
  734. } {{p1 bye done} {p2 bye done} {p3 bye done}}
  735. test socket-4.2 {byte order problems, socket numbers, htons} {socket} {
  736.     set x ok
  737.     if {[catch {socket -server dodo 0x3000} msg]} {
  738. set x $msg
  739.     } else {
  740. close $msg
  741.     }
  742.     set x
  743. } ok
  745. test socket-5.1 {byte order problems, socket numbers, htons} 
  746. {socket unixOnly notRoot} {
  747.     set x {couldn't open socket: not owner}
  748.     if {![catch {socket -server dodo 0x1} msg]} {
  749.         set x {htons problem, should be disallowed, are you running as SU?}
  750. close $msg
  751.     }
  752.     set x
  753. } {couldn't open socket: not owner}
  754. test socket-5.2 {byte order problems, socket numbers, htons} {socket} {
  755.     set x {couldn't open socket: port number too high}
  756.     if {![catch {socket -server dodo 0x10000} msg]} {
  757. set x {port resolution problem, should be disallowed}
  758. close $msg
  759.     }
  760.     set x
  761. } {couldn't open socket: port number too high}
  762. test socket-5.3 {byte order problems, socket numbers, htons} 
  763. {socket unixOnly notRoot} {
  764.     set x {couldn't open socket: not owner}
  765.     if {![catch {socket -server dodo 21} msg]} {
  766. set x {htons problem, should be disallowed, are you running as SU?}
  767. close $msg
  768.     }
  769.     set x
  770. } {couldn't open socket: not owner}
  772. test socket-6.1 {accept callback error} {socket stdio} {
  773.     file delete $path(script)
  774.     set f [open $path(script) w]
  775.     puts $f {
  776. gets stdin port
  777. socket 127.0.0.1 $port
  778.     }
  779.     close $f
  780.     set f [open "|[list [interpreter] $path(script)]" r+]
  781.     proc bgerror args {
  782. global x
  783. set x $args
  784.     }
  785.     proc accept {s a p} {expr 10 / 0}
  786.     set s [socket -server accept 0]
  787.     puts $f [lindex [fconfigure $s -sockname] 2]
  788.     close $f
  789.     set timer [after 10000 "set x timed_out"]
  790.     vwait x
  791.     after cancel $timer
  792.     close $s
  793.     rename bgerror {}
  794.     set x
  795. } {{divide by zero}}
  797. test socket-7.1 {testing socket specific options} {socket stdio} {
  798.     file delete $path(script)
  799.     set f [open $path(script) w]
  800.     puts $f {
  801. set ss [socket -server accept 0]
  802. proc accept args {
  803.     global x
  804.     set x done
  805. }
  806. puts ready
  807. puts [lindex [fconfigure $ss -sockname] 2]
  808. set timer [after 10000 "set x timed_out"]
  809. vwait x
  810. after cancel $timer
  811.     }
  812.     close $f
  813.     set f [open "|[list [interpreter] $path(script)]" r]
  814.     gets $f
  815.     gets $f listen
  816.     set s [socket 127.0.0.1 $listen]
  817.     set p [fconfigure $s -peername]
  818.     close $s
  819.     close $f
  820.     set l ""
  821.     lappend l [string compare [lindex $p 0] 127.0.0.1]
  822.     lappend l [string compare [lindex $p 2] $listen]
  823.     lappend l [llength $p]
  824. } {0 0 3}
  825. test socket-7.2 {testing socket specific options} {socket stdio} {
  826.     file delete $path(script)
  827.     set f [open $path(script) w]
  828.     puts $f {
  829. set ss [socket -server accept 2821]
  830. proc accept args {
  831.     global x
  832.     set x done
  833. }
  834. puts ready
  835. puts [lindex [fconfigure $ss -sockname] 2]
  836. set timer [after 10000 "set x timed_out"]
  837. vwait x
  838. after cancel $timer
  839.     }
  840.     close $f
  841.     set f [open "|[list [interpreter] $path(script)]" r]
  842.     gets $f
  843.     gets $f listen
  844.     set s [socket 127.0.0.1 $listen]
  845.     set p [fconfigure $s -sockname]
  846.     close $s
  847.     close $f
  848.     list [llength $p] 
  849.     [regexp {^(127.0.0.1|0.0.0.0)$} [lindex $p 0]] 
  850.     [expr {[lindex $p 2] == $listen}]
  851. } {3 1 0}
  852. test socket-7.3 {testing socket specific options} {socket} {
  853.     set s [socket -server accept 0]
  854.     set l [fconfigure $s]
  855.     close $s
  856.     update
  857.     llength $l
  858. } 14
  859. test socket-7.4 {testing socket specific options} {socket} {
  860.     set s [socket -server accept 0]
  861.     proc accept {s a p} {
  862. global x
  863. set x [fconfigure $s -sockname]
  864. close $s
  865.     }
  866.     set listen [lindex [fconfigure $s -sockname] 2]
  867.     set s1 [socket [info hostname] $listen]
  868.     set timer [after 10000 "set x timed_out"]
  869.     vwait x
  870.     after cancel $timer
  871.     close $s
  872.     close $s1
  873.     set l ""
  874.     lappend l [expr {[lindex $x 2] == $listen}] [llength $x]
  875. } {1 3}
  876. test socket-7.5 {testing socket specific options} {socket unixOrPc} {
  877.     set s [socket -server accept 0]
  878.     proc accept {s a p} {
  879. global x
  880. set x [fconfigure $s -sockname]
  881. close $s
  882.     }
  883.     set listen [lindex [fconfigure $s -sockname] 2]
  884.     set s1 [socket 127.0.0.1 $listen]
  885.     set timer [after 10000 "set x timed_out"]
  886.     vwait x
  887.     after cancel $timer
  888.     close $s
  889.     close $s1
  890.     set l ""
  891.     lappend l [lindex $x 0] [expr {[lindex $x 2] == $listen}] [llength $x]
  892. } {127.0.0.1 1 3}
  894. test socket-8.1 {testing -async flag on sockets} {socket} {
  895.     # NOTE: This test may fail on some Solaris 2.4 systems. If it does,
  896.     # check that you have these patches installed (using showrev -p):
  897.     #
  898.     # 101907-05, 101925-02, 101945-14, 101959-03, 101969-05, 101973-03,
  899.     # 101977-03, 101981-02, 101985-01, 102001-03, 102003-01, 102007-01,
  900.     # 102011-02, 102024-01, 102039-01, 102044-01, 102048-01, 102062-03,
  901.     # 102066-04, 102070-01, 102105-01, 102153-03, 102216-01, 102232-01,
  902.     # 101878-03, 101879-01, 101880-03, 101933-01, 101950-01, 102030-01,
  903.     # 102057-08, 102140-01, 101920-02, 101921-09, 101922-07, 101923-03
  904.     #
  905.     # If after installing these patches you are still experiencing a
  906.     # problem, please email jyl@eng.sun.com. We have not observed this
  907.     # failure on Solaris 2.5, so another option (instead of installing
  908.     # these patches) is to upgrade to Solaris 2.5.
  909.     set s [socket -server accept 0]
  910.     proc accept {s a p} {
  911. global x
  912. puts $s bye
  913. close $s
  914. set x done
  915.     }
  916.     set s1 [socket -async [info hostname] [lindex [fconfigure $s -sockname] 2]]
  917.     vwait x
  918.     set z [gets $s1]
  919.     close $s
  920.     close $s1
  921.     set z
  922. } bye
  924. test socket-9.1 {testing spurious events} {socket} {
  925.     set len 0
  926.     set spurious 0
  927.     set done 0
  928.     proc readlittle {s} {
  929. global spurious done len
  930. set l [read $s 1]
  931. if {[string length $l] == 0} {
  932.     if {![eof $s]} {
  933. incr spurious
  934.     } else {
  935. close $s
  936. set done 1
  937.     }
  938. } else {
  939.     incr len [string length $l]
  940. }
  941.     }
  942.     proc accept {s a p} {
  943. fconfigure $s -buffering none -blocking off
  944. fileevent $s readable [list readlittle $s]
  945.     }
  946.     set s [socket -server accept 0]
  947.     set c [socket [info hostname] [lindex [fconfigure $s -sockname] 2]]
  948.     puts -nonewline $c 01234567890123456789012345678901234567890123456789
  949.     close $c
  950.     set timer [after 10000 "set done timed_out"]
  951.     vwait done
  952.     after cancel $timer
  953.     close $s
  954.     list $spurious $len
  955. } {0 50}
  956. test socket-9.2 {testing async write, fileevents, flush on close} {socket} {
  957.     set firstblock ""
  958.     for {set i 0} {$i < 5} {incr i} {set firstblock "a$firstblock$firstblock"}
  959.     set secondblock ""
  960.     for {set i 0} {$i < 16} {incr i} {
  961. set secondblock "b$secondblock$secondblock"
  962.     }
  963.     set l [socket -server accept 0]
  964.     proc accept {s a p} {
  965. fconfigure $s -blocking 0 -translation lf -buffersize 16384 
  966. -buffering line
  967. fileevent $s readable "readable $s"
  968.     }
  969.     proc readable {s} {
  970. set l [gets $s]
  971. fileevent $s readable {}
  972. after 1000 respond $s
  973.     }
  974.     proc respond {s} {
  975. global firstblock
  976. puts -nonewline $s $firstblock
  977. after 1000 writedata $s
  978.     }
  979.     proc writedata {s} {
  980. global secondblock
  981. puts -nonewline $s $secondblock
  982. close $s
  983.     }
  984.     set s [socket [info hostname] [lindex [fconfigure $l -sockname] 2]]
  985.     fconfigure $s -blocking 0 -trans lf -buffering line
  986.     set count 0
  987.     puts $s hello
  988.     proc readit {s} {
  989. global count done
  990. set l [read $s]
  991. incr count [string length $l]
  992. if {[eof $s]} {
  993.     close $s
  994.     set done 1
  995. }
  996.     }
  997.     fileevent $s readable "readit $s"
  998.     set timer [after 10000 "set done timed_out"]
  999.     vwait done
  1000.     after cancel $timer
  1001.     close $l
  1002.     set count
  1003. } 65566
  1004. test socket-9.3 {testing EOF stickyness} {socket} {
  1005.     proc count_to_eof {s} {
  1006. global count done timer
  1007. set l [gets $s]
  1008. if {[eof $s]} {
  1009.     incr count
  1010.     if {$count > 9} {
  1011. close $s
  1012. set done true
  1013. set count {eof is sticky}
  1014. after cancel $timer
  1015.     }
  1016. }
  1017.     }
  1018.     proc timerproc {} {
  1019. global done count c
  1020. set done true
  1021. set count {timer went off, eof is not sticky}
  1022. close $c
  1023.     }
  1024.     set count 0
  1025.     set done false
  1026.     proc write_then_close {s} {
  1027. puts $s bye
  1028. close $s
  1029.     }
  1030.     proc accept {s a p} {
  1031. fconfigure $s -buffering line -translation lf
  1032. fileevent $s writable "write_then_close $s"
  1033.     }
  1034.     set s [socket -server accept 0]
  1035.     set c [socket [info hostname] [lindex [fconfigure $s -sockname] 2]]
  1036.     fconfigure $c -blocking off -buffering line -translation lf
  1037.     fileevent $c readable "count_to_eof $c"
  1038.     set timer [after 1000 timerproc]
  1039.     vwait done
  1040.     close $s
  1041.     set count
  1042. } {eof is sticky}
  1044. removeFile script
  1046. test socket-10.1 {testing socket accept callback error handling} {socket} {
  1047.     set goterror 0
  1048.     proc bgerror args {global goterror; set goterror 1}
  1049.     set s [socket -server accept 0]
  1050.     proc accept {s a p} {close $s; error}
  1051.     set c [socket 127.0.0.1 [lindex [fconfigure $s -sockname] 2]]
  1052.     vwait goterror
  1053.     close $s
  1054.     close $c
  1055.     set goterror
  1056. } 1
  1058. test socket-11.1 {tcp connection} {socket doTestsWithRemoteServer} {
  1059.     sendCommand {
  1060. set socket9_1_test_server [socket -server accept 2834]
  1061. proc accept {s a p} {
  1062.     puts $s done
  1063.     close $s
  1064. }
  1065.     }
  1066.     set s [socket $remoteServerIP 2834]
  1067.     set r [gets $s]
  1068.     close $s
  1069.     sendCommand {close $socket9_1_test_server}
  1070.     set r
  1071. } done
  1072. test socket-11.2 {client specifies its port} {socket doTestsWithRemoteServer} {
  1073.     if {[info exists port]} {
  1074. incr port
  1075.     } else {
  1076. set port [expr 2048 + [pid]%1024]
  1077.     }
  1078.     sendCommand {
  1079. set socket9_2_test_server [socket -server accept 2835]
  1080. proc accept {s a p} {
  1081.     puts $s $p
  1082.     close $s
  1083. }
  1084.     }
  1085.     set s [socket -myport $port $remoteServerIP 2835]
  1086.     set r [gets $s]
  1087.     close $s
  1088.     sendCommand {close $socket9_2_test_server}
  1089.     if {$r == $port} {
  1090. set result ok
  1091.     } else {
  1092. set result broken
  1093.     }
  1094.     set result
  1095. } ok
  1096. test socket-11.3 {trying to connect, no server} {socket doTestsWithRemoteServer} {
  1097.     set status ok
  1098.     if {![catch {set s [socket $remoteServerIp 2836]}]} {
  1099. if {![catch {gets $s}]} {
  1100.     set status broken
  1101. }
  1102. close $s
  1103.     }
  1104.     set status
  1105. } ok
  1106. test socket-11.4 {remote echo, one line} {socket doTestsWithRemoteServer} {
  1107.     sendCommand {
  1108. set socket10_6_test_server [socket -server accept 2836]
  1109. proc accept {s a p} {
  1110.     fileevent $s readable [list echo $s]
  1111.     fconfigure $s -buffering line -translation crlf
  1112. }
  1113. proc echo {s} {
  1114.     set l [gets $s]
  1115.     if {[eof $s]} {
  1116. close $s
  1117.     } else {
  1118. puts $s $l
  1119.     }
  1120. }
  1121.     }
  1122.     set f [socket $remoteServerIP 2836]
  1123.     fconfigure $f -translation crlf -buffering line
  1124.     puts $f hello
  1125.     set r [gets $f]
  1126.     close $f
  1127.     sendCommand {close $socket10_6_test_server}
  1128.     set r
  1129. } hello
  1130. test socket-11.5 {remote echo, 50 lines} {socket doTestsWithRemoteServer} {
  1131.     sendCommand {
  1132. set socket10_7_test_server [socket -server accept 2836]
  1133. proc accept {s a p} {
  1134.     fileevent $s readable [list echo $s]
  1135.     fconfigure $s -buffering line -translation crlf
  1136. }
  1137. proc echo {s} {
  1138.     set l [gets $s]
  1139.     if {[eof $s]} {
  1140. close $s
  1141.     } else {
  1142. puts $s $l
  1143.     }
  1144. }
  1145.     }
  1146.     set f [socket $remoteServerIP 2836]
  1147.     fconfigure $f -translation crlf -buffering line
  1148.     for {set cnt 0} {$cnt < 50} {incr cnt} {
  1149. puts $f "hello, $cnt"
  1150. if {[string compare [gets $f] "hello, $cnt"] != 0} {
  1151.     break
  1152. }
  1153.     }
  1154.     close $f
  1155.     sendCommand {close $socket10_7_test_server}
  1156.     set cnt
  1157. } 50
  1158. # Macintosh sockets can have more than one server per port
  1159. if {$tcl_platform(platform) == "macintosh"} {
  1160.     set conflictResult {0 2836}
  1161. } else {
  1162.     set conflictResult {1 {couldn't open socket: address already in use}}
  1163. }
  1164. test socket-11.6 {socket conflict} {socket doTestsWithRemoteServer} {
  1165.     set s1 [socket -server accept 2836]
  1166.     if {[catch {set s2 [socket -server accept 2836]} msg]} {
  1167. set result [list 1 $msg]
  1168.     } else {
  1169. set result [list 0 [lindex [fconfigure $s2 -sockname] 2]]
  1170. close $s2
  1171.     }
  1172.     close $s1
  1173.     set result
  1174. } $conflictResult
  1175. test socket-11.7 {server with several clients} {socket doTestsWithRemoteServer} {
  1176.     sendCommand {
  1177. set socket10_9_test_server [socket -server accept 2836]
  1178. proc accept {s a p} {
  1179.     fconfigure $s -buffering line
  1180.     fileevent $s readable [list echo $s]
  1181. }
  1182. proc echo {s} {
  1183.     set l [gets $s]
  1184.     if {[eof $s]} {
  1185. close $s
  1186.     } else {
  1187. puts $s $l
  1188.     }
  1189. }
  1190.     }
  1191.     set s1 [socket $remoteServerIP 2836]
  1192.     fconfigure $s1 -buffering line
  1193.     set s2 [socket $remoteServerIP 2836]
  1194.     fconfigure $s2 -buffering line
  1195.     set s3 [socket $remoteServerIP 2836]
  1196.     fconfigure $s3 -buffering line
  1197.     for {set i 0} {$i < 100} {incr i} {
  1198. puts $s1 hello,s1
  1199. gets $s1
  1200. puts $s2 hello,s2
  1201. gets $s2
  1202. puts $s3 hello,s3
  1203. gets $s3
  1204.     }
  1205.     close $s1
  1206.     close $s2
  1207.     close $s3
  1208.     sendCommand {close $socket10_9_test_server}
  1209.     set i
  1210. } 100    
  1211. test socket-11.8 {client with several servers} {socket doTestsWithRemoteServer} {
  1212.     sendCommand {
  1213. set s1 [socket -server "accept 4003" 4003]
  1214. set s2 [socket -server "accept 4004" 4004]
  1215. set s3 [socket -server "accept 4005" 4005]
  1216. proc accept {mp s a p} {
  1217.     puts $s $mp
  1218.     close $s
  1219. }
  1220.     }
  1221.     set s1 [socket $remoteServerIP 4003]
  1222.     set s2 [socket $remoteServerIP 4004]
  1223.     set s3 [socket $remoteServerIP 4005]
  1224.     set l ""
  1225.     lappend l [gets $s1] [gets $s1] [eof $s1] [gets $s2] [gets $s2] [eof $s2] 
  1226. [gets $s3] [gets $s3] [eof $s3]
  1227.     close $s1
  1228.     close $s2
  1229.     close $s3
  1230.     sendCommand {
  1231. close $s1
  1232. close $s2
  1233. close $s3
  1234.     }
  1235.     set l
  1236. } {4003 {} 1 4004 {} 1 4005 {} 1}
  1237. test socket-11.9 {accept callback error} {socket doTestsWithRemoteServer} {
  1238.     set s [socket -server accept 2836]
  1239.     proc accept {s a p} {expr 10 / 0}
  1240.     proc bgerror args {
  1241. global x
  1242. set x $args
  1243.     }
  1244.     if {[catch {sendCommand {
  1245.     set peername [fconfigure $callerSocket -peername]
  1246.     set s [socket [lindex $peername 0] 2836]
  1247.     close $s
  1248.       }} msg]} {
  1249. close $s
  1250. error $msg
  1251.     }
  1252.     set timer [after 10000 "set x timed_out"]
  1253.     vwait x
  1254.     after cancel $timer
  1255.     close $s
  1256.     rename bgerror {}
  1257.     set x
  1258. } {{divide by zero}}
  1259. test socket-11.10 {testing socket specific options} {socket doTestsWithRemoteServer} {
  1260.     sendCommand {
  1261. set socket10_12_test_server [socket -server accept 2836]
  1262. proc accept {s a p} {close $s}
  1263.     }
  1264.     set s [socket $remoteServerIP 2836]
  1265.     set p [fconfigure $s -peername]
  1266.     set n [fconfigure $s -sockname]
  1267.     set l ""
  1268.     lappend l [lindex $p 2] [llength $p] [llength $p]
  1269.     close $s
  1270.     sendCommand {close $socket10_12_test_server}
  1271.     set l
  1272. } {2836 3 3}
  1273. test socket-11.11 {testing spurious events} {socket doTestsWithRemoteServer} {
  1274.     sendCommand {
  1275. set socket10_13_test_server [socket -server accept 2836]
  1276. proc accept {s a p} {
  1277.     fconfigure $s -translation "auto lf"
  1278.     after 100 writesome $s
  1279. }
  1280. proc writesome {s} {
  1281.     for {set i 0} {$i < 100} {incr i} {
  1282. puts $s "line $i from remote server"
  1283.     }
  1284.     close $s
  1285. }
  1286.     }
  1287.     set len 0
  1288.     set spurious 0
  1289.     set done 0
  1290.     proc readlittle {s} {
  1291. global spurious done len
  1292. set l [read $s 1]
  1293. if {[string length $l] == 0} {
  1294.     if {![eof $s]} {
  1295. incr spurious
  1296.     } else {
  1297. close $s
  1298. set done 1
  1299.     }
  1300. } else {
  1301.     incr len [string length $l]
  1302. }
  1303.     }
  1304.     set c [socket $remoteServerIP 2836]
  1305.     fileevent $c readable "readlittle $c"
  1306.     set timer [after 40000 "set done timed_out"]
  1307.     vwait done
  1308.     after cancel $timer
  1309.     sendCommand {close $socket10_13_test_server}
  1310.     list $spurious $len $done
  1311. } {0 2690 1}
  1313. test socket-11.12 {testing EOF stickyness} {socket doTestsWithRemoteServer} {
  1314.     set counter 0
  1315.     set done 0
  1316.     proc count_up {s} {
  1317. global counter done after_id
  1318. set l [gets $s]
  1319. if {[eof $s]} {
  1320.     incr counter
  1321.     if {$counter > 9} {
  1322. set done {EOF is sticky}
  1323. after cancel $after_id
  1324. close $s
  1325.     }
  1326. }
  1327.     }
  1328.     proc timed_out {} {
  1329. global c done
  1330. set done {timed_out, EOF is not sticky}
  1331. close $c
  1332.     }
  1333.     sendCommand {
  1334. set socket10_14_test_server [socket -server accept 2836]
  1335. proc accept {s a p} {
  1336.     after 100 close $s
  1337. }
  1338.     }
  1339.     set c [socket $remoteServerIP 2836]
  1340.     fileevent $c readable [list count_up $c]
  1341.     set after_id [after 1000 timed_out]
  1342.     vwait done
  1343.     sendCommand {close $socket10_14_test_server}
  1344.     set done
  1345. } {EOF is sticky}
  1347. test socket-11.13 {testing async write, async flush, async close} 
  1348. {socket doTestsWithRemoteServer} {
  1349.     proc readit {s} {
  1350. global count done
  1351. set l [read $s]
  1352. incr count [string length $l]
  1353. if {[eof $s]} {
  1354.     close $s
  1355.     set done 1
  1356. }
  1357.     }
  1358.     sendCommand {
  1359. set firstblock ""
  1360. for {set i 0} {$i < 5} {incr i} {
  1361. set firstblock "a$firstblock$firstblock"
  1362. }
  1363. set secondblock ""
  1364. for {set i 0} {$i < 16} {incr i} {
  1365.     set secondblock "b$secondblock$secondblock"
  1366. }
  1367. set l [socket -server accept 2845]
  1368. proc accept {s a p} {
  1369.     fconfigure $s -blocking 0 -translation lf -buffersize 16384 
  1370. -buffering line
  1371.     fileevent $s readable "readable $s"
  1372. }
  1373. proc readable {s} {
  1374.     set l [gets $s]
  1375.     fileevent $s readable {}
  1376.     after 1000 respond $s
  1377. }
  1378. proc respond {s} {
  1379.     global firstblock
  1380.     puts -nonewline $s $firstblock
  1381.     after 1000 writedata $s
  1382. }
  1383. proc writedata {s} {
  1384.     global secondblock
  1385.     puts -nonewline $s $secondblock
  1386.     close $s
  1387. }
  1388.     }
  1389.     set s [socket $remoteServerIP 2845]
  1390.     fconfigure $s -blocking 0 -trans lf -buffering line
  1391.     set count 0
  1392.     puts $s hello
  1393.     fileevent $s readable "readit $s"
  1394.     set timer [after 10000 "set done timed_out"]
  1395.     vwait done
  1396.     after cancel $timer
  1397.     sendCommand {close $l}
  1398.     set count
  1399. } 65566
  1401. set path(script1) [makeFile {} script1]
  1402. set path(script2) [makeFile {} script2]
  1404. test socket-12.1 {testing inheritance of server sockets} {socket stdio exec} {
  1405.     file delete $path(script1)
  1406.     file delete $path(script2)
  1408.     # Script1 is just a 10 second delay.  If the server socket
  1409.     # is inherited, it will be held open for 10 seconds
  1411.     set f [open $path(script1) w]
  1412.     puts $f {
  1413. after 10000 exit
  1414. vwait forever
  1415.     }
  1416.     close $f
  1418.     # Script2 creates the server socket, launches script1,
  1419.     # waits a second, and exits.  The server socket will now
  1420.     # be closed unless script1 inherited it.
  1422.     set f [open $path(script2) w]
  1423.     puts $f [list set tcltest [interpreter]]
  1424.     puts -nonewline $f {
  1425. set f [socket -server accept 0]
  1426. puts [lindex [fconfigure $f -sockname] 2]
  1427. proc accept { file addr port } {
  1428.     close $file
  1429. }
  1430. exec $tcltest }
  1431.     puts $f [list $path(script1) &]
  1432.     puts $f {
  1433. close $f
  1434. after 1000 exit
  1435. vwait forever
  1436.     }
  1437.     close $f
  1439.     # Launch script2 and wait 5 seconds
  1441.     ### exec [interpreter] script2 &
  1442.     set p [open "|[list [interpreter] $path(script2)]" r]
  1443.     gets $p listen
  1445.     after 5000 { set ok_to_proceed 1 }
  1446.     vwait ok_to_proceed
  1448.     # If we can still connect to the server, the socket got inherited.
  1450.     if {[catch {socket 127.0.0.1 $listen} msg]} {
  1451. set x {server socket was not inherited}
  1452.     } else {
  1453. close $msg
  1454. set x {server socket was inherited}
  1455.     }
  1457.     close $p
  1458.     set x
  1459. } {server socket was not inherited}
  1460. test socket-12.2 {testing inheritance of client sockets} {socket stdio exec} {
  1461.     file delete $path(script1)
  1462.     file delete $path(script2)
  1464.     # Script1 is just a 20 second delay.  If the server socket
  1465.     # is inherited, it will be held open for 10 seconds
  1467.     set f [open $path(script1) w]
  1468.     puts $f {
  1469. after 20000 exit
  1470. vwait forever
  1471.     }
  1472.     close $f
  1474.     # Script2 opens the client socket and writes to it.  It then
  1475.     # launches script1 and exits.  If the child process inherited the
  1476.     # client socket, the socket will still be open.
  1478.     set f [open $path(script2) w]
  1479.     puts $f [list set tcltest [interpreter]]
  1480.     puts -nonewline $f {
  1481.         gets stdin port
  1482. set f [socket 127.0.0.1 $port]
  1483.         exec $tcltest }
  1484.     puts $f [list $path(script1) &]
  1485.     puts $f {
  1486. puts $f testing
  1487. flush $f
  1488. after 1000 exit
  1489. vwait forever
  1490.     }
  1491.     close $f
  1493.     # Create the server socket
  1495.     set server [socket -server accept 0]
  1496.     proc accept { file host port } {
  1497. # When the client connects, establish the read handler
  1498. global server
  1499. close $server
  1500. fileevent $file readable [list getdata $file]
  1501. fconfigure $file -buffering line -blocking 0
  1502. return
  1503.     }
  1504.     proc getdata { file } {
  1505. # Read handler on the accepted socket.
  1506. global x
  1507. global failed
  1508. set status [catch {read $file} data]
  1509. if {$status != 0} {
  1510.     set x {read failed, error was $data}
  1511.     catch { close $file }
  1512. } elseif {[string compare {} $data]} {
  1513. } elseif {[fblocked $file]} {
  1514. } elseif {[eof $file]} {
  1515.     if {$failed} {
  1516. set x {client socket was inherited}
  1517.     } else {
  1518. set x {client socket was not inherited}
  1519.     }
  1520.     catch { close $file }
  1521. } else {
  1522.     set x {impossible case}
  1523.     catch { close $file }
  1524. }
  1525. return
  1526.     }
  1528.     # If the socket doesn't hit end-of-file in 10 seconds, the
  1529.     # script1 process must have inherited the client.
  1531.     set failed 0
  1532.     after 10000 [list set failed 1]
  1534.     # Launch the script2 process
  1535.     ### exec [interpreter] script2 &
  1537.     set p [open "|[list [interpreter] $path(script2)]" w]
  1538.     puts $p [lindex [fconfigure $server -sockname] 2] ; flush $p
  1540.     vwait x
  1541.     if {!$failed} {
  1542. vwait failed
  1543.     }
  1544.     close $p
  1545.     set x
  1546. } {client socket was not inherited}
  1547. test socket-12.3 {testing inheritance of accepted sockets} {socket stdio exec} {
  1548.     file delete $path(script1)
  1549.     file delete $path(script2)
  1551.     set f [open $path(script1) w]
  1552.     puts $f {
  1553. after 10000 exit
  1554. vwait forever
  1555.     }
  1556.     close $f
  1558.     set f [open $path(script2) w]
  1559.     puts $f [list set tcltest [interpreter]]
  1560.     puts -nonewline $f {
  1561. set server [socket -server accept 0]
  1562. puts stdout [lindex [fconfigure $server -sockname] 2]
  1563. proc accept { file host port } }
  1564.     puts $f {
  1565.     puts -nonewline $f {
  1566.     global tcltest
  1567.     puts $file {test data on socket}
  1568.     exec $tcltest }
  1569.     puts $f [list $path(script1) &]
  1570.     puts $f {
  1571.     after 1000 exit
  1572. }
  1573.     puts $f } 
  1574.     puts $f {
  1575. vwait forever
  1576.     }
  1577.     close $f
  1579.     # Launch the script2 process and connect to it.  See how long
  1580.     # the socket stays open
  1582.     ## exec [interpreter] script2 &
  1583.     set p [open "|[list [interpreter] $path(script2)]" r]
  1584.     gets $p listen
  1586.     after 1000 set ok_to_proceed 1
  1587.     vwait ok_to_proceed
  1589.     set f [socket 127.0.0.1 $listen]
  1590.     fconfigure $f -buffering full -blocking 0
  1591.     fileevent $f readable [list getdata $f]
  1593.     # If the socket is still open after 5 seconds, the script1 process
  1594.     # must have inherited the accepted socket.
  1596.     set failed 0
  1597.     after 5000 set failed 1
  1599.     proc getdata { file } {
  1600. # Read handler on the client socket.
  1601. global x
  1602. global failed
  1603. set status [catch {read $file} data]
  1604. if {$status != 0} {
  1605.     set x {read failed, error was $data}
  1606.     catch { close $file }
  1607. } elseif {[string compare {} $data]} {
  1608. } elseif {[fblocked $file]} {
  1609. } elseif {[eof $file]} {
  1610.     if {$failed} {
  1611. set x {accepted socket was inherited}
  1612.     } else {
  1613. set x {accepted socket was not inherited}
  1614.     }
  1615.     catch { close $file }
  1616. } else {
  1617.     set x {impossible case}
  1618.     catch { close $file }
  1619. }
  1620. return
  1621.     }
  1622.     
  1623.     vwait x
  1625.     close $p
  1626.     set x
  1627. } {accepted socket was not inherited}
  1629. test socket-13.1 {Testing use of shared socket between two threads} 
  1630. -constraints {socket testthread} -setup {
  1632.     threadReap
  1634.     set path(script) [makeFile {
  1635. set f [socket -server accept 0]
  1636. set listen [lindex [fconfigure $f -sockname] 2]
  1637. proc accept {s a p} {
  1638.             fileevent $s readable [list echo $s]
  1639.             fconfigure $s -buffering line
  1640.         }
  1641. proc echo {s} {
  1642.      global i
  1643.              set l [gets $s]
  1644.              if {[eof $s]} {
  1645.                  global x
  1646.                  close $s
  1647.                  set x done
  1648.              } else { 
  1649.          incr i
  1650.                  puts $s $l
  1651.              }
  1652. }
  1653. set i 0
  1654. vwait x
  1655. close $f
  1657. # thread cleans itself up.
  1658. testthread exit
  1659.     } script]
  1661. } -body {
  1662.     # create a thread
  1663.     set serverthread [testthread create [list source $path(script) ] ]
  1664.     update
  1665.     set port [testthread send $serverthread {set listen}]
  1666.     update
  1668.     after 1000
  1669.     set s [socket 127.0.0.1 $port]
  1670.     fconfigure $s -buffering line
  1672.     catch {
  1673. puts $s "hello"
  1674. gets $s result
  1675.     }
  1676.     close $s
  1677.     update
  1679.     after 2000
  1680.     lappend result [threadReap]
  1681. } -cleanup {
  1682.     removeFile script
  1683. } -result {hello 1}
  1685. removeFile script1
  1686. removeFile script2
  1688. # cleanup
  1689. if {[string match sock* $commandSocket] == 1} {
  1690.    puts $commandSocket exit
  1691.    flush $commandSocket
  1692. }
  1693. catch {close $commandSocket}
  1694. catch {close $remoteProcChan}
  1695. ::tcltest::cleanupTests
  1696. flush stdout
  1697. return