Diff

Differences From Artifact [29322e679c]:

To Artifact [eaefd1ceb9]:


66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

# The build dir is added as the first element of $PATH
set auto_path [linsert $auto_path 0 [lindex [split $env(PATH) ";:"] 0]]
# Load the tls package
package require tls 1.6

set tlsServerPort 8048

# Specify where the certificates are

set certsDir	[file join [file dirname [info script]] certs]
set serverCert	[file join $certsDir server.pem]







<

|







66
67
68
69
70
71
72

73
74
75
76
77
78
79
80
81

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

# The build dir is added as the first element of $PATH

# Load the tls package
package require tls

set tlsServerPort 8048

# Specify where the certificates are

set certsDir	[file join [file dirname [info script]] certs]
set serverCert	[file join $certsDir server.pem]
300
301
302
303
304
305
306

307
308
309
310
311
312
313
314
315
test tlsIO-1.12 {arg parsing for socket command} {socket} {
    list [catch {tls::socket foo badport} msg] $msg
} {1 {expected integer but got "badport"}}

test tlsIO-2.1 {tcp connection} {socket stdio} {
    removeFile script
    set f [open script w]

    puts $f {
	set auto_path [linsert $auto_path 0 [lindex [split $env(PATH) ";:"] 0]]
	package require tls
	set timer [after 2000 "set x timed_out"]
    }
    puts $f "set f \[tls::socket -server accept -certfile $serverCert -cafile $caCert -keyfile $serverKey 8828 \]"
    puts $f {
	proc accept {file addr port} {
	    global x







>

<







299
300
301
302
303
304
305
306
307

308
309
310
311
312
313
314
test tlsIO-1.12 {arg parsing for socket command} {socket} {
    list [catch {tls::socket foo badport} msg] $msg
} {1 {expected integer but got "badport"}}

test tlsIO-2.1 {tcp connection} {socket stdio} {
    removeFile script
    set f [open script w]
    puts $f [list set auto_path $auto_path]
    puts $f {

	package require tls
	set timer [after 2000 "set x timed_out"]
    }
    puts $f "set f \[tls::socket -server accept -certfile $serverCert -cafile $caCert -keyfile $serverKey 8828 \]"
    puts $f {
	proc accept {file addr port} {
	    global x
342
343
344
345
346
347
348

349
350
351
352
353
354
355
356
357
} else {
    set port [expr {$tlsServerPort + [pid]%1024}]
}

test tlsIO-2.2 {tcp connection with client port specified} {socket stdio} {
    removeFile script
    set f [open script w]

    puts $f {
	set auto_path [linsert $auto_path 0 [lindex [split $env(PATH) ";:"] 0]]
	package require tls
	set timer [after 2000 "set x done"]
    }
    puts $f "set f \[tls::socket -server accept -certfile $serverCert -cafile $caCert -keyfile $serverKey 8829 \]"
    puts $f {
	proc accept {sock addr port} {
            global x







>

<







341
342
343
344
345
346
347
348
349

350
351
352
353
354
355
356
} else {
    set port [expr {$tlsServerPort + [pid]%1024}]
}

test tlsIO-2.2 {tcp connection with client port specified} {socket stdio} {
    removeFile script
    set f [open script w]
    puts $f [list set auto_path $auto_path]
    puts $f {

	package require tls
	set timer [after 2000 "set x done"]
    }
    puts $f "set f \[tls::socket -server accept -certfile $serverCert -cafile $caCert -keyfile $serverKey 8829 \]"
    puts $f {
	proc accept {sock addr port} {
            global x
382
383
384
385
386
387
388

389
390
391
392
393
394
395
396
397
    close $f
    set x
} [list ready "hello $port"]

test tlsIO-2.3 {tcp connection with client interface specified} {socket stdio} {
    removeFile script
    set f [open script w]

    puts $f {
	set auto_path [linsert $auto_path 0 [lindex [split $env(PATH) ";:"] 0]]
	package require tls
	set timer [after 2000 "set x done"]
    }
    puts $f "set f \[tls::socket -server accept -certfile $serverCert -cafile $caCert -keyfile $serverKey 8830 \]"
    puts $f {
	proc accept {sock addr port} {
            global x







>

<







381
382
383
384
385
386
387
388
389

390
391
392
393
394
395
396
    close $f
    set x
} [list ready "hello $port"]

test tlsIO-2.3 {tcp connection with client interface specified} {socket stdio} {
    removeFile script
    set f [open script w]
    puts $f [list set auto_path $auto_path]
    puts $f {

	package require tls
	set timer [after 2000 "set x done"]
    }
    puts $f "set f \[tls::socket -server accept -certfile $serverCert -cafile $caCert -keyfile $serverKey 8830 \]"
    puts $f {
	proc accept {sock addr port} {
            global x
420
421
422
423
424
425
426

427
428
429
430
431
432
433
434
435
    close $f
    set x
} {ready {hello 127.0.0.1}}

test tlsIO-2.4 {tcp connection with server interface specified} {socket stdio} {
    removeFile script
    set f [open script w]

    puts $f {
	set auto_path [linsert $auto_path 0 [lindex [split $env(PATH) ";:"] 0]]
	package require tls
	set timer [after 2000 "set x done"]
    }
    puts $f "set f \[tls::socket -server accept -certfile $serverCert -cafile $caCert -keyfile $serverKey -myaddr [info hostname] 8831 \]"
    puts $f {
	proc accept {sock addr port} {
            global x







>

<







419
420
421
422
423
424
425
426
427

428
429
430
431
432
433
434
    close $f
    set x
} {ready {hello 127.0.0.1}}

test tlsIO-2.4 {tcp connection with server interface specified} {socket stdio} {
    removeFile script
    set f [open script w]
    puts $f [list set auto_path $auto_path]
    puts $f {

	package require tls
	set timer [after 2000 "set x done"]
    }
    puts $f "set f \[tls::socket -server accept -certfile $serverCert -cafile $caCert -keyfile $serverKey -myaddr [info hostname] 8831 \]"
    puts $f {
	proc accept {sock addr port} {
            global x
457
458
459
460
461
462
463

464
465
466
467
468
469
470
471
472
    close $f
    set x
} {ready hello}

test tlsIO-2.5 {tcp connection with redundant server port} {socket stdio} {
    removeFile script
    set f [open script w]

    puts $f {
	set auto_path [linsert $auto_path 0 [lindex [split $env(PATH) ";:"] 0]]
	package require tls
	set timer [after 2000 "set x done"]
    }
    puts $f "set f \[tls::socket -server accept -certfile $serverCert -cafile $caCert -keyfile $serverKey 8832 \]"
    puts $f {
	proc accept {sock addr port} {
            global x







>

<







456
457
458
459
460
461
462
463
464

465
466
467
468
469
470
471
    close $f
    set x
} {ready hello}

test tlsIO-2.5 {tcp connection with redundant server port} {socket stdio} {
    removeFile script
    set f [open script w]
    puts $f [list set auto_path $auto_path]
    puts $f {

	package require tls
	set timer [after 2000 "set x done"]
    }
    puts $f "set f \[tls::socket -server accept -certfile $serverCert -cafile $caCert -keyfile $serverKey 8832 \]"
    puts $f {
	proc accept {sock addr port} {
            global x
504
505
506
507
508
509
510

511
512
513
514
515
516
517
518
519
    }
    set status
} ok

test tlsIO-2.7 {echo server, one line} {socket stdio} {
    removeFile script
    set f [open script w]

    puts $f {
	set auto_path [linsert $auto_path 0 [lindex [split $env(PATH) ";:"] 0]]
	package require tls
	set timer [after 2000 "set x done"]
    }
    puts $f "set f \[tls::socket -server accept -certfile $serverCert -cafile $caCert -keyfile $serverKey 8834 \]"
    puts $f {
	proc accept {s a p} {
            fileevent $s readable [list echo $s]







>

<







503
504
505
506
507
508
509
510
511

512
513
514
515
516
517
518
    }
    set status
} ok

test tlsIO-2.7 {echo server, one line} {socket stdio} {
    removeFile script
    set f [open script w]
    puts $f [list set auto_path $auto_path]
    puts $f {

	package require tls
	set timer [after 2000 "set x done"]
    }
    puts $f "set f \[tls::socket -server accept -certfile $serverCert -cafile $caCert -keyfile $serverKey 8834 \]"
    puts $f {
	proc accept {s a p} {
            fileevent $s readable [list echo $s]
548
549
550
551
552
553
554

555
556
557
558
559
560
561
562
563
    set y [gets $f]
    close $f
    list $x $y
} {{hello abcdefghijklmnop} done}

test tlsIO-2.8 {echo server, loop 50 times, single connection} {socket stdio} {
    set f [open script w]

    puts $f {
	set auto_path [linsert $auto_path 0 [lindex [split $env(PATH) ";:"] 0]]
    	package require tls
    }
    puts $f "set f \[tls::socket -server accept -certfile $serverCert -cafile $caCert -keyfile $serverKey 8835 \]"
    puts $f {
	proc accept {s a p} {
            fileevent $s readable [list echo $s]
            fconfigure $s -buffering line







>

<







547
548
549
550
551
552
553
554
555

556
557
558
559
560
561
562
    set y [gets $f]
    close $f
    list $x $y
} {{hello abcdefghijklmnop} done}

test tlsIO-2.8 {echo server, loop 50 times, single connection} {socket stdio} {
    set f [open script w]
    puts $f [list set auto_path $auto_path]
    puts $f {

    	package require tls
    }
    puts $f "set f \[tls::socket -server accept -certfile $serverCert -cafile $caCert -keyfile $serverKey 8835 \]"
    puts $f {
	proc accept {s a p} {
            fileevent $s readable [list echo $s]
            fconfigure $s -buffering line
600
601
602
603
604
605
606

607
608
609
610
611
612
613
614
615
    set x
} {done 50}

test tlsIO-2.9 {socket conflict} {socket stdio} {
    set s [tls::socket -server accept 8828]
    removeFile script
    set f [open script w]

    puts -nonewline $f {
	set auto_path [linsert $auto_path 0 [lindex [split $env(PATH) ";:"] 0]]
	package require tls
	tls::socket -server accept 8828
    }
    close $f
    set f [open "|[list $::tcltest::tcltest script]" r]
    gets $f
    after 100







>

<







599
600
601
602
603
604
605
606
607

608
609
610
611
612
613
614
    set x
} {done 50}

test tlsIO-2.9 {socket conflict} {socket stdio} {
    set s [tls::socket -server accept 8828]
    removeFile script
    set f [open script w]
    puts $f [list set auto_path $auto_path]
    puts -nonewline $f {

	package require tls
	tls::socket -server accept 8828
    }
    close $f
    set f [open "|[list $::tcltest::tcltest script]" r]
    gets $f
    after 100
687
688
689
690
691
692
693

694
695
696
697
698
699
700
701
702

test tlsIO-2.12 {tcp connection; no certificates specified} \
	{socket stdio unixOnly} {
    # There is a debug assertion on Windows/SSL that causes a crash when the
    # certificate isn't specified.
    removeFile script
    set f [open script w]

    puts $f {
	set auto_path [linsert $auto_path 0 [lindex [split $env(PATH) ";:"] 0]]
	package require tls
	set timer [after 2000 "set x timed_out"]
	set f [tls::socket -server accept 8828]
	proc accept {file addr port} {
	    global x
	    set x done
            close $file







>

<







686
687
688
689
690
691
692
693
694

695
696
697
698
699
700
701

test tlsIO-2.12 {tcp connection; no certificates specified} \
	{socket stdio unixOnly} {
    # There is a debug assertion on Windows/SSL that causes a crash when the
    # certificate isn't specified.
    removeFile script
    set f [open script w]
    puts $f [list set auto_path $auto_path]
    puts $f {

	package require tls
	set timer [after 2000 "set x timed_out"]
	set f [tls::socket -server accept 8828]
	proc accept {file addr port} {
	    global x
	    set x done
            close $file
720
721
722
723
724
725
726

727
728
729
730
731
732
733
734
735
    close $f
    set x
} {ready done {}}

test tlsIO-3.1 {socket conflict} {socket stdio} {
    removeFile script
    set f [open script w]

    puts $f {
	set auto_path [linsert $auto_path 0 [lindex [split $env(PATH) ";:"] 0]]
	package require tls
    }
    puts $f "set f \[tls::socket -server accept -certfile $serverCert -cafile $caCert -keyfile $serverKey 8828 \]"
    puts $f {
	puts ready
	gets stdin
	close $f







>

<







719
720
721
722
723
724
725
726
727

728
729
730
731
732
733
734
    close $f
    set x
} {ready done {}}

test tlsIO-3.1 {socket conflict} {socket stdio} {
    removeFile script
    set f [open script w]
    puts $f [list set auto_path $auto_path]
    puts $f {

	package require tls
    }
    puts $f "set f \[tls::socket -server accept -certfile $serverCert -cafile $caCert -keyfile $serverKey 8828 \]"
    puts $f {
	puts ready
	gets stdin
	close $f
745
746
747
748
749
750
751

752
753
754
755
756
757
758
759
760
    close $f
    set x
} {1 {couldn't open socket: address already in use}}

test tlsIO-3.2 {server with several clients} {socket stdio} {
    removeFile script
    set f [open script w]

    puts $f {
	set auto_path [linsert $auto_path 0 [lindex [split $env(PATH) ";:"] 0]]
	package require tls
	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
    }
    puts $f "set s \[tls::socket -server accept -certfile $serverCert -cafile $caCert -keyfile $serverKey 8828 \]"







>

<







744
745
746
747
748
749
750
751
752

753
754
755
756
757
758
759
    close $f
    set x
} {1 {couldn't open socket: address already in use}}

test tlsIO-3.2 {server with several clients} {socket stdio} {
    removeFile script
    set f [open script w]
    puts $f [list set auto_path $auto_path]
    puts $f {

	package require tls
	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
    }
    puts $f "set s \[tls::socket -server accept -certfile $serverCert -cafile $caCert -keyfile $serverKey 8828 \]"
814
815
816
817
818
819
820

821
822
823
824
825
826
827
828
829
    set x
} {ready done}

test tlsIO-4.1 {server with several clients} {socket stdio} {
    # have seen intermittent hangs on Windows
    removeFile script
    set f [open script w]

    puts $f {
	set auto_path [linsert $auto_path 0 [lindex [split $env(PATH) ";:"] 0]]
	package require tls
	gets stdin
    }
    puts $f "set s \[tls::socket -certfile $clientCert -cafile $caCert -keyfile $clientKey 127.0.0.1 8828 \]"
    puts $f {
	fconfigure $s -buffering line
	for {set i 0} {$i < 100} {incr i} {







>

<







813
814
815
816
817
818
819
820
821

822
823
824
825
826
827
828
    set x
} {ready done}

test tlsIO-4.1 {server with several clients} {socket stdio} {
    # have seen intermittent hangs on Windows
    removeFile script
    set f [open script w]
    puts $f [list set auto_path $auto_path]
    puts $f {

	package require tls
	gets stdin
    }
    puts $f "set s \[tls::socket -certfile $clientCert -cafile $caCert -keyfile $clientKey 127.0.0.1 8828 \]"
    puts $f {
	fconfigure $s -buffering line
	for {set i 0} {$i < 100} {incr i} {
922
923
924
925
926
927
928

929
930
931
932
933
934
935
936
937
} {couldn't open socket: not owner}

test tlsIO-6.1 {accept callback error} {socket stdio} {
    # There is a debug assertion on Windows/SSL that causes a crash when the
    # certificate isn't specified.
    removeFile script
    set f [open script w]

    puts $f {
	set auto_path [linsert $auto_path 0 [lindex [split $env(PATH) ";:"] 0]]
    	package require tls
	gets stdin
    }
    puts $f [list tls::socket -cafile $caCert 127.0.0.1 8848]
    close $f
    set f [open "|[list $::tcltest::tcltest script]" r+]
    proc bgerror args {







>

<







921
922
923
924
925
926
927
928
929

930
931
932
933
934
935
936
} {couldn't open socket: not owner}

test tlsIO-6.1 {accept callback error} {socket stdio} {
    # There is a debug assertion on Windows/SSL that causes a crash when the
    # certificate isn't specified.
    removeFile script
    set f [open script w]
    puts $f [list set auto_path $auto_path]
    puts $f {

    	package require tls
	gets stdin
    }
    puts $f [list tls::socket -cafile $caCert 127.0.0.1 8848]
    close $f
    set f [open "|[list $::tcltest::tcltest script]" r+]
    proc bgerror args {
950
951
952
953
954
955
956

957
958
959
960
961
962
963
964
965
    rename bgerror {}
    set x
} {{divide by zero}}

test tlsIO-7.1 {testing socket specific options} {socket stdio} {
    removeFile script
    set f [open script w]

    puts $f {
	set auto_path [linsert $auto_path 0 [lindex [split $env(PATH) ";:"] 0]]
	package require tls
    }
    puts $f [list tls::socket -server accept \
	    -certfile $serverCert -cafile $caCert -keyfile $serverKey 8820]
    puts $f {
	proc accept args {
	    global x







>

<







949
950
951
952
953
954
955
956
957

958
959
960
961
962
963
964
    rename bgerror {}
    set x
} {{divide by zero}}

test tlsIO-7.1 {testing socket specific options} {socket stdio} {
    removeFile script
    set f [open script w]
    puts $f [list set auto_path $auto_path]
    puts $f {

	package require tls
    }
    puts $f [list tls::socket -server accept \
	    -certfile $serverCert -cafile $caCert -keyfile $serverKey 8820]
    puts $f {
	proc accept args {
	    global x
984
985
986
987
988
989
990

991
992
993
994
995
996
997
998
999
    lappend l [string compare [lindex $p 2] 8820]
    lappend l [llength $p]
} {0 0 3}

test tlsIO-7.2 {testing socket specific options} {socket stdio} {
    removeFile script
    set f [open script w]

    puts $f {
	set auto_path [linsert $auto_path 0 [lindex [split $env(PATH) ";:"] 0]]
	package require tls
    }
    puts $f "tls::socket -server accept -certfile $serverCert -cafile $caCert -keyfile $serverKey 8821"
    puts $f {
	proc accept args {
	    global x
	    set x done







>

<







983
984
985
986
987
988
989
990
991

992
993
994
995
996
997
998
    lappend l [string compare [lindex $p 2] 8820]
    lappend l [llength $p]
} {0 0 3}

test tlsIO-7.2 {testing socket specific options} {socket stdio} {
    removeFile script
    set f [open script w]
    puts $f [list set auto_path $auto_path]
    puts $f {

	package require tls
    }
    puts $f "tls::socket -server accept -certfile $serverCert -cafile $caCert -keyfile $serverKey 8821"
    puts $f {
	proc accept args {
	    global x
	    set x done
1756
1757
1758
1759
1760
1761
1762

1763
1764
1765
1766
1767
1768
1769
1770
1771

    # 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 tclsh $::tcltest::tcltest]

    puts $f {
	set auto_path [linsert $auto_path 0 [lindex [split $env(PATH) ";:"] 0]]
	package require tls
    }
    puts $f "set f \[tls::socket -server accept \
	    -certfile $serverCert -cafile $caCert -keyfile $serverKey 8828\]"
    puts $f {
	proc accept { file addr port } {
	    close $file







>

<







1755
1756
1757
1758
1759
1760
1761
1762
1763

1764
1765
1766
1767
1768
1769
1770

    # 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 tclsh $::tcltest::tcltest]
    puts $f [list set auto_path $auto_path]
    puts $f {

	package require tls
    }
    puts $f "set f \[tls::socket -server accept \
	    -certfile $serverCert -cafile $caCert -keyfile $serverKey 8828\]"
    puts $f {
	proc accept { file addr port } {
	    close $file
1813
1814
1815
1816
1817
1818
1819

1820
1821
1822
1823
1824
1825
1826
1827
1828

    # 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 tclsh $::tcltest::tcltest]

    puts $f {
	set auto_path [linsert $auto_path 0 [lindex [split $env(PATH) ";:"] 0]]
	package require tls
    }
    puts $f "set f \[tls::socket -certfile $clientCert -cafile $caCert \
	    -keyfile $clientKey 127.0.0.1 8829\]"
    puts $f {
	exec $tclsh script1 &
	puts $f testing







>

<







1812
1813
1814
1815
1816
1817
1818
1819
1820

1821
1822
1823
1824
1825
1826
1827

    # 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 tclsh $::tcltest::tcltest]
    puts $f [list set auto_path $auto_path]
    puts $f {

	package require tls
    }
    puts $f "set f \[tls::socket -certfile $clientCert -cafile $caCert \
	    -keyfile $clientKey 127.0.0.1 8829\]"
    puts $f {
	exec $tclsh script1 &
	puts $f testing
1874
1875
1876
1877
1878
1879
1880

1881
1882
1883
1884
1885
1886
1887
1888
1889
	after 10000 exit
	vwait forever
    }
    close $f

    set f [open script2 w]
    puts $f [list set tclsh $::tcltest::tcltest]

    puts $f {
	set auto_path [linsert $auto_path 0 [lindex [split $env(PATH) ";:"] 0]]
	package require tls
    }
    puts $f "set f \[tls::socket -server accept \
	    -certfile $serverCert -cafile $caCert -keyfile $serverKey 8930\]"
    puts $f {
	proc accept { file host port } {
	    global tclsh







>

<







1873
1874
1875
1876
1877
1878
1879
1880
1881

1882
1883
1884
1885
1886
1887
1888
	after 10000 exit
	vwait forever
    }
    close $f

    set f [open script2 w]
    puts $f [list set tclsh $::tcltest::tcltest]
    puts $f [list set auto_path $auto_path]
    puts $f {

	package require tls
    }
    puts $f "set f \[tls::socket -server accept \
	    -certfile $serverCert -cafile $caCert -keyfile $serverKey 8930\]"
    puts $f {
	proc accept { file host port } {
	    global tclsh
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
test tlsIO-13.1 {Testing use of shared socket between two threads} \
	{socket testthread} {
    # HOBBS: never tested
    removeFile script
    threadReap

    makeFile {
	set auto_path [linsert $auto_path 0 [lindex [split $env(PATH) ";:"] 0]]
    	package require tls
	set f [tls::socket -server accept 8828]
	proc accept {s a p} {
            fileevent $s readable [list echo $s]
            fconfigure $s -buffering line
        }
	proc echo {s} {







<







1925
1926
1927
1928
1929
1930
1931

1932
1933
1934
1935
1936
1937
1938
test tlsIO-13.1 {Testing use of shared socket between two threads} \
	{socket testthread} {
    # HOBBS: never tested
    removeFile script
    threadReap

    makeFile {

    	package require tls
	set f [tls::socket -server accept 8828]
	proc accept {s a p} {
            fileevent $s readable [list echo $s]
            fconfigure $s -buffering line
        }
	proc echo {s} {