Tcl Source Code

Check-in [32d82f87bd]
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to [email protected]
or submit via the online form by Sep 9.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:* tests/tests/socket.test: Changed so tests don't reuse sockets, since Windows is slow to release sockets.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | core-8-1-branch-old
Files: files | file ages | folders
SHA1: 32d82f87bd3c8e566f3a103ed81398359f2b01d4
User & Date: stanton 1999-04-05 22:18:03
Context
1999-04-05
22:18
*** empty log message *** check-in: 3b3a73e766 user: stanton tags: core-8-1-branch-old
22:18
* tests/tests/socket.test: Changed so tests don't reuse sockets, since Windows is slow to release so... check-in: 32d82f87bd user: stanton tags: core-8-1-branch-old
21:58
* win/tclWinConsole.c: * win/tclWinPipe.c: * win/tclWinSerial.c: Fixed race condition where backgrou... check-in: 9c78cc3ee2 user: stanton tags: core-8-1-branch-old
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to tests/socket.test.

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
...
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
...
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
...
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
...
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
...
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
...
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
...
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
...
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
...
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
...
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
#
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: socket.test,v 1.1.2.10 1999/03/25 01:25:14 redman Exp $

# 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
................................................................................
    set port [expr 2048 + [pid]%1024]
}
test socket-2.2 {tcp connection with client port specified} {socket 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
................................................................................
	after cancel $timer
	close $f
    }
    close $f
    set f [open "|[list $tcltest script]" r]
    gets $f x
    global port
    if {[catch {socket -myport $port 127.0.0.1 2828} sock]} {
        set x $sock
	close [socket 127.0.0.1 2828]
	puts stderr $sock
    } else {
        puts $sock hello
	flush $sock
        lappend x [gets $f]
        close $sock
    }
................................................................................
    set x
} [list ready "hello $port"]
test socket-2.3 {tcp connection with client interface specified} {socket 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 127.0.0.1 127.0.0.1 2828} sock]} {
        set x $sock
    } else {
        puts $sock hello
	flush $sock
        lappend x [gets $f]
        close $sock
    }
................................................................................
    set x
} {ready {hello 127.0.0.1}}
test socket-2.4 {tcp connection with server interface specified} {socket 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
    }
................................................................................
    set x
} {ready hello}
test socket-2.5 {tcp connection with redundant server port} {socket 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 127.0.0.1 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} {socket} {
    set status ok
    if {![catch {set sock [socket 127.0.0.1 2828]}]} {
	if {![catch {gets $sock}]} {
	    set status broken
	}
	close $sock
    }
    set status
} ok
test socket-2.7 {echo server, one line} {socket 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]} {
................................................................................
	after cancel $timer
	close $f
	puts done
    }
    close $f
    set f [open "|[list $tcltest script]" r]
    gets $f
    set s [socket 127.0.0.1 2828]
    fconfigure $s -buffering line -translation lf
    puts $s "hello abcdefghijklmnop"
    after 1000
    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} {socket 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]
................................................................................
	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 127.0.0.1 2828]
    fconfigure $s -buffering line
    catch {
	for {set x 0} {$x < 50} {incr x} {
	    puts $s "hello abcdefghijklmnop"
	    gets $s
	}
    }






|







 







|







 







|

|







 







|







 







|







 







|







 







|







 







|







 







|












|












|







 







|










|
<
<
|







 







|
<


|







6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
...
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
...
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
...
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
...
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
...
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
...
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
...
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
...
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
...
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459


460
461
462
463
464
465
466
467
...
477
478
479
480
481
482
483
484

485
486
487
488
489
490
491
492
493
494
#
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: socket.test,v 1.1.2.11 1999/04/05 22:18:03 stanton Exp $

# 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
................................................................................
    set port [expr 2048 + [pid]%1024]
}
test socket-2.2 {tcp connection with client port specified} {socket stdio} {
    removeFile script
    set f [open script w]
    puts $f {
	set timer [after 2000 "set x done"]
        set f [socket -server accept 2829]
	proc accept {file addr port} {
            global x
            puts "[gets $file] $port"
            close $file
            set x done
	}
	puts ready
................................................................................
	after cancel $timer
	close $f
    }
    close $f
    set f [open "|[list $tcltest script]" r]
    gets $f x
    global port
    if {[catch {socket -myport $port 127.0.0.1 2829} sock]} {
        set x $sock
	close [socket 127.0.0.1 2829]
	puts stderr $sock
    } else {
        puts $sock hello
	flush $sock
        lappend x [gets $f]
        close $sock
    }
................................................................................
    set x
} [list ready "hello $port"]
test socket-2.3 {tcp connection with client interface specified} {socket stdio} {
    removeFile script
    set f [open script w]
    puts $f {
	set timer [after 2000 "set x done"]
        set f [socket  -server accept 2830]
	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 127.0.0.1 127.0.0.1 2830} sock]} {
        set x $sock
    } else {
        puts $sock hello
	flush $sock
        lappend x [gets $f]
        close $sock
    }
................................................................................
    set x
} {ready {hello 127.0.0.1}}
test socket-2.4 {tcp connection with server interface specified} {socket 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] 2831]
	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] 2831} sock]} {
        set x $sock
    } else {
        puts $sock hello
	flush $sock
        lappend x [gets $f]
        close $sock
    }
................................................................................
    set x
} {ready hello}
test socket-2.5 {tcp connection with redundant server port} {socket stdio} {
    removeFile script
    set f [open script w]
    puts $f {
	set timer [after 2000 "set x done"]
        set f [socket -server accept 2832]
	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 127.0.0.1 2832} 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} {socket} {
    set status ok
    if {![catch {set sock [socket 127.0.0.1 2833]}]} {
	if {![catch {gets $sock}]} {
	    set status broken
	}
	close $sock
    }
    set status
} ok
test socket-2.7 {echo server, one line} {socket stdio} {
    removeFile script
    set f [open script w]
    puts $f {
	set timer [after 2000 "set x done"]
	set f [socket -server accept 2834]
	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]} {
................................................................................
	after cancel $timer
	close $f
	puts done
    }
    close $f
    set f [open "|[list $tcltest script]" r]
    gets $f
    set s [socket 127.0.0.1 2834]
    fconfigure $s -buffering line -translation lf
    puts $s "hello abcdefghijklmnop"
    after 1000
    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} {socket stdio} {
    makeFile {


	set f [socket -server accept 2835]
	proc accept {s a p} {
            fileevent $s readable [list echo $s]
            fconfigure $s -buffering line
        }
	proc echo {s} {
	     global i
             set l [gets $s]
................................................................................
	set i 0
	puts ready
	set timer [after 20000 "set x done"]
	vwait x
	after cancel $timer
	close $f
	puts "done $i"
    } script

    set f [open "|[list $tcltest script]" r]
    gets $f
    set s [socket 127.0.0.1 2835]
    fconfigure $s -buffering line
    catch {
	for {set x 0} {$x < 50} {incr x} {
	    puts $s "hello abcdefghijklmnop"
	    gets $s
	}
    }