Check-in [a1d3dcc242]
Bounty program for improvements to Tcl and certain Tcl packages.
Overview
Comment:Fix test 2.2.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: a1d3dcc242eac5a287a1e5a133f1cdbd6d216e9c
User & Date: awb on 2000-06-02 21:44:59
Other Links: manifest | tags
Context
2000-06-02
21:50
Fix test 2.3. check-in: 7f3358aca3 user: awb tags: trunk
21:44
Fix test 2.2. check-in: a1d3dcc242 user: awb tags: trunk
20:45
*** empty log message *** check-in: 570604a410 user: awb tags: trunk
Changes

Modified tests/tlsIo.test from [eb8672a93e] to [6a79fb9151].

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
# Commands tested in this file: socket.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# 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: tlsIo.test,v 1.3 2000/06/02 20:45:38 awb 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











|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
# Commands tested in this file: socket.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# 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: tlsIo.test,v 1.4 2000/06/02 21:44:59 awb 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
65
66
67
68
69
70
71






72
73
74
75
76
77
78
if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

# Load the tls package
package require tls







# Some tests require the testthread command

set ::tcltest::testConstraints(testthread) \
	[expr {[info commands testthread] != {}}]

#






>
>
>
>
>
>







65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

# Load the tls package
package require tls

set serverCert [file join $::tcltest::testsDirectory certs server.pem]
set clientCert [file join $::tcltest::testsDirectory certs client.pem]
set caCert [file join $::tcltest::testsDirectory certs cacert.pem]
set serverKey [file join $::tcltest::testsDirectory certs skey.pem]
set clientKey [file join $::tcltest::testsDirectory certs ckey.pem]

# Some tests require the testthread command

set ::tcltest::testConstraints(testthread) \
	[expr {[info commands testthread] != {}}]

#
282
283
284
285
286
287
288
289
290
291
292
293
294

295

296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311


312
313
314
315
316
317
318
319
320
321
if [info exists port] {
    incr port
} else { 
    set port [expr 2048 + [pid]%1024]
}

test socket-2.2 {tcp connection with client port specified} {socket stdio pcCrash} {
    removeFile script
    set f [open script w]
    puts $f {
	package require tls
	set timer [after 2000 "set x done"]

        set f [tls::socket -server accept 2829]

	proc accept {file addr port} {
            global x
            puts "[gets $file] $port"
            close $file
            set x done
	}
	puts ready
	vwait x
	after cancel $timer
	close $f
    }
    close $f
    set f [open "|[list $::tcltest::tcltest script]" r]
    gets $f x
    global port
    if {[catch {tls::socket -myport $port 127.0.0.1 2829} sock]} {


        set x $sock
	close [tls::socket 127.0.0.1 2829]
	puts stderr $sock
    } else {
        puts $sock hello
	flush $sock
        lappend x [gets $f]
        close $sock
    }
    close $f






|





>
|
>















|
>
>

|
<







288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323

324
325
326
327
328
329
330
if [info exists port] {
    incr port
} else { 
    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 {
	package require tls
	set timer [after 2000 "set x done"]
    }
    puts $f "set f \[tls::socket -server accept -certfile $serverCert -cafile $caCert -keyfile $serverKey 2829 \]"
    puts $f {
	proc accept {file addr port} {
            global x
            puts "[gets $file] $port"
            close $file
            set x done
	}
	puts ready
	vwait x
	after cancel $timer
	close $f
    }
    close $f
    set f [open "|[list $::tcltest::tcltest script]" r]
    gets $f x
    global port
    if {[catch {tls::socket -myport $port \
	-certfile $clientCert -cafile $caCert \
	-keyfile $clientKey 127.0.0.1 2829} sock]} {
        set x $sock
	catch {close [tls::socket 127.0.0.1 2829]}

    } else {
        puts $sock hello
	flush $sock
        lappend x [gets $f]
        close $sock
    }
    close $f
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
    close $f
    set f [open "|[list $::tcltest::tcltest script]" r]
    gets $f x
    if {[catch {tls::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
    }
    close $f
    set x
} {ready {hello 127.0.0.1}}







|







352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
    close $f
    set f [open "|[list $::tcltest::tcltest script]" r]
    gets $f x
    if {[catch {tls::socket -myaddr 127.0.0.1 127.0.0.1 2830} sock]} {
        set x $sock
    } else {
        puts $sock hello
	catch {flush $sock}
        lappend x [gets $f]
        close $sock
    }
    close $f
    set x
} {ready {hello 127.0.0.1}}