Tcl Source Code

Check-in [9bdbccc71e]
Login
Bounty program for improvements to Tcl and certain Tcl packages.

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

Overview
Comment:* tests/winNotify.test: * tests/ioCmd.test: * tests/event.test: Changed to use new style conditionals.

* tests/encoding.test: Fixed nonportable test.

Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | core-8-1-branch-old
Files: files | file ages | folders
SHA1: 9bdbccc71e90b779ab8f9c3eae11f0bb8ee8c55d
User & Date: stanton 1999-03-24 04:25:42
Context
1999-03-24
04:25
*** empty log message *** check-in: 66e21ca670 user: stanton tags: core-8-1-branch-old
04:25
* tests/winNotify.test: * tests/ioCmd.test: * tests/event.test: Changed to use new style conditional... check-in: 9bdbccc71e user: stanton tags: core-8-1-branch-old
04:25
* tests/winNotify.test: * mac/tclMacNotify.c: * win/tclWinNotify.c: * unix/tclUnixNotfy.c: * generic... check-in: 1b663177f8 user: stanton tags: core-8-1-branch-old
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to tests/encoding.test.

4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
..
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107



108
109




110
111
112
113
114
115


116
117
118
119
120
121
122
#
# Copyright (c) 1997 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: encoding.test,v 1.1.2.6 1999/03/24 02:49:04 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

proc toutf {args} {
    global x
................................................................................
    set old [fconfigure stdout -encoding]
    fconfigure stdout -encoding jis0208
    set x [fconfigure stdout -encoding]
    fconfigure stdout -encoding $old
    set x
} {jis0208}

test encoding-4.1 {Tcl_GetEncodingNames} {pcOnly testencoding} {
    file mkdir tmp/encoding
    close [open tmp/encoding/junk.enc w]
    close [open tmp/encoding/junk2.enc w]
    cd tmp
    set path [testencoding path]
    testencoding path .
    set x [encoding names]
    testencoding path $path
    cd ..
    file delete -force tmp
    set x
} {junk utf-8 cp1252 junk2 identity unicode iso8859-1}
test encoding-4.1 {Tcl_GetEncodingNames} {unixOnly testencoding} {
    file mkdir tmp/encoding
    close [open tmp/encoding/junk.enc w]
    close [open tmp/encoding/junk2.enc w]
    cd tmp
    set path [testencoding path]



    testencoding path .
    set x [encoding names]




    testencoding path $path
    cd ..
    file delete -force tmp
    set x
} {junk utf-8 junk2 identity unicode iso8859-1}




test encoding-5.1 {Tcl_SetSystemEncoding} {
    set old [encoding system]
    encoding system jis0208
    set x [encoding convertto \u4e4e]
    encoding system identity
    encoding system $old






|







 







|





|
|
<
<
<
|
<
<
<
<
<
<
<
>
>
>

|
>
>
>
>



<
<
<
>
>







4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
..
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96



97







98
99
100
101
102
103
104
105
106
107
108
109



110
111
112
113
114
115
116
117
118
#
# Copyright (c) 1997 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: encoding.test,v 1.1.2.7 1999/03/24 04:25:42 stanton Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

proc toutf {args} {
    global x
................................................................................
    set old [fconfigure stdout -encoding]
    fconfigure stdout -encoding jis0208
    set x [fconfigure stdout -encoding]
    fconfigure stdout -encoding $old
    set x
} {jis0208}

test encoding-4.1 {Tcl_GetEncodingNames} {
    file mkdir tmp/encoding
    close [open tmp/encoding/junk.enc w]
    close [open tmp/encoding/junk2.enc w]
    cd tmp
    set path [testencoding path]
    testencoding path {}
    catch {unset encodings}



    catch {unset x}







    foreach encoding [encoding names] {
	set encodings($encoding) 1
    }
    testencoding path .
    foreach encoding [encoding names] {
	if {![info exists encodings($encoding)]} {
	    lappend x $encoding
	}
    }
    testencoding path $path
    cd ..
    file delete -force tmp



    lsort $x
} {junk junk2}

test encoding-5.1 {Tcl_SetSystemEncoding} {
    set old [encoding system]
    encoding system jis0208
    set x [encoding convertto \u4e4e]
    encoding system identity
    encoding system $old

Changes to tests/event.test.

5
6
7
8
9
10
11
12
13
14
15
16
17
18







19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
...
274
275
276
277
278
279
280
281
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
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
...
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
#
# Copyright (c) 1995-1997 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: event.test,v 1.1.2.5 1999/03/24 02:49:06 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

if {[catch {testfilehandler create 0 off off}] == 0 } {







    test event-1.1 {Tcl_CreateFileHandler, reading} {
	testfilehandler close
	testfilehandler create 0 readable off
	testfilehandler clear 0
	testfilehandler oneevent
	set result ""
	lappend result [testfilehandler counts 0]
	testfilehandler fillpartial 0
	testfilehandler oneevent
	lappend result [testfilehandler counts 0]
	testfilehandler oneevent
	lappend result [testfilehandler counts 0]
	testfilehandler close
	set result
    } {{0 0} {1 0} {2 0}}
    test event-1.2 {Tcl_CreateFileHandler, writing} {nonPortable} {
	# This test is non-portable because on some systems (e.g.
	# SunOS 4.1.3) pipes seem to be writable always.
	testfilehandler close
	testfilehandler create 0 off writable
	testfilehandler clear 0
	testfilehandler oneevent
	set result ""
	lappend result [testfilehandler counts 0]
	testfilehandler fillpartial 0
	testfilehandler oneevent
	lappend result [testfilehandler counts 0]
	testfilehandler fill 0
	testfilehandler oneevent
	lappend result [testfilehandler counts 0]
	testfilehandler close
	set result
    } {{0 1} {0 2} {0 2}}
    test event-1.3 {Tcl_DeleteFileHandler} {nonPortable} {
	testfilehandler close
	testfilehandler create 2 disabled disabled
	testfilehandler create 1 readable writable
	testfilehandler create 0 disabled disabled
	testfilehandler fillpartial 1
	set result ""
	testfilehandler oneevent
	lappend result [testfilehandler counts 1]
	testfilehandler oneevent
	lappend result [testfilehandler counts 1]
	testfilehandler oneevent
	lappend result [testfilehandler counts 1]
	testfilehandler create 1 off off
	testfilehandler oneevent
	lappend result [testfilehandler counts 1]
	testfilehandler close
	set result
    } {{0 1} {1 1} {1 2} {0 0}}

    test event-2.1 {Tcl_DeleteFileHandler} {nonPortable} {
	testfilehandler close
	testfilehandler create 2 disabled disabled
	testfilehandler create 1 readable writable
	testfilehandler fillpartial 1
	set result ""
	testfilehandler oneevent
	lappend result [testfilehandler counts 1]
	testfilehandler oneevent
	lappend result [testfilehandler counts 1]
	testfilehandler oneevent
	lappend result [testfilehandler counts 1]
	testfilehandler create 1 off off
	testfilehandler oneevent
	lappend result [testfilehandler counts 1]
	testfilehandler close
	set result
    } {{0 1} {1 1} {1 2} {0 0}}
    test event-2.2 {Tcl_DeleteFileHandler, fd reused & events still pending} {nonPortable} {
	testfilehandler close
	testfilehandler create 0 readable writable
	testfilehandler fillpartial 0
	set result ""
	testfilehandler oneevent
	lappend result [testfilehandler counts 0]
	testfilehandler close
	testfilehandler create 0 readable writable
	testfilehandler oneevent
	lappend result [testfilehandler counts 0]
	testfilehandler close
	set result
    } {{0 1} {0 0}}

    test event-3.1 {FileHandlerCheckProc, TCL_FILE_EVENTS off } {
	testfilehandler close
	testfilehandler create 1 readable writable
	testfilehandler fillpartial 1
	testfilehandler windowevent
	set result [testfilehandler counts 1]
	testfilehandler close
	set result
    } {0 0}

    test event-4.1 {FileHandlerEventProc, race between event and disabling} {nonPortable} {
	update
	testfilehandler close
	testfilehandler create 2 disabled disabled
	testfilehandler create 1 readable writable
	testfilehandler fillpartial 1
	set result ""
	testfilehandler oneevent
	lappend result [testfilehandler counts 1]
	testfilehandler oneevent
	lappend result [testfilehandler counts 1]
	testfilehandler oneevent
	lappend result [testfilehandler counts 1]
	testfilehandler create 1 disabled disabled
	testfilehandler oneevent
	lappend result [testfilehandler counts 1]
	testfilehandler close
	set result
    } {{0 1} {1 1} {1 2} {0 0}}
    test event-4.2 {FileHandlerEventProc, TCL_FILE_EVENTS off} {nonPortable} {
	update
	testfilehandler close
	testfilehandler create 1 readable writable
	testfilehandler create 2 readable writable
	testfilehandler fillpartial 1
	testfilehandler fillpartial 2
	testfilehandler oneevent
	set result ""
	lappend result [testfilehandler counts 1] [testfilehandler counts 2]
	testfilehandler windowevent
	lappend result [testfilehandler counts 1] [testfilehandler counts 2]
	testfilehandler close
	set result
    } {{0 0} {0 1} {0 0} {0 1}}
    testfilehandler close
    update
}

test event-5.1 {Tcl_BackgroundError, HandleBgErrors procedures} {
    catch {rename bgerror {}}
    proc bgerror msg {
	global errorInfo errorCode x
	lappend x [list $msg $errorInfo $errorCode]
    }
................................................................................
# that. the other option would be to use fork a test but it
# then becomes more a file/exec test than a bgerror test.

# end of bgerror tests
catch {rename bgerror {}}


if {[info commands testexithandler] != ""} {
    test event-8.1 {Tcl_CreateExitHandler procedure} {stdio} {
	set child [open |[list [info nameofexecutable]] r+]
	puts $child "testexithandler create 41; testexithandler create 4"
	puts $child "testexithandler create 6; exit"
	flush $child
	set result [read $child]
	close $child
	set result
    } {even 6
even 4
odd 41
}

    test event-9.1 {Tcl_DeleteExitHandler procedure} {stdio} {
	set child [open |[list [info nameofexecutable]] r+]
	puts $child "testexithandler create 41; testexithandler create 4"
	puts $child "testexithandler create 6; testexithandler delete 41"
	puts $child "testexithandler create 16; exit"
	flush $child
	set result [read $child]
	close $child
	set result
    } {even 16
even 6
even 4
}
    test event-9.2 {Tcl_DeleteExitHandler procedure} {stdio} {
	set child [open |[list [info nameofexecutable]] r+]
	puts $child "testexithandler create 41; testexithandler create 4"
	puts $child "testexithandler create 6; testexithandler delete 4"
	puts $child "testexithandler create 16; exit"
	flush $child
	set result [read $child]
	close $child
	set result
    } {even 16
even 6
odd 41
}
    test event-9.3 {Tcl_DeleteExitHandler procedure} {stdio} {
	set child [open |[list [info nameofexecutable]] r+]
	puts $child "testexithandler create 41; testexithandler create 4"
	puts $child "testexithandler create 6; testexithandler delete 6"
	puts $child "testexithandler create 16; exit"
	flush $child
	set result [read $child]
	close $child
	set result
    } {even 16
even 4
odd 41
}
    test event-9.4 {Tcl_DeleteExitHandler procedure} {stdio} {
	set child [open |[list [info nameofexecutable]] r+]
	puts $child "testexithandler create 41; testexithandler delete 41"
	puts $child "testexithandler create 16; exit"
	flush $child
	set result [read $child]
	close $child
	set result
    } {even 16
}
}

test event-10.1 {Tcl_Exit procedure} {stdio} {
    set child [open |[list [info nameofexecutable]] r+]
    puts $child "exit 3"
    list [catch {close $child} msg] $msg [lindex $errorCode 0] \
        [lindex $errorCode 2]
................................................................................
    set y before
    set z before
    after 300
    update
    list $x $y $z
} {x-done before z-done}

if {[info commands testfilehandler] != ""} {
    test event-13.1 {Tcl_WaitForFile procedure, readable} unixOnly {
	foreach i [after info] {
	    after cancel $i
	}
	after 100 set x timeout
	testfilehandler close
	testfilehandler create 1 off off
	set x "no timeout"
	set result [testfilehandler wait 1 readable 0]
	update
	testfilehandler close
	list $result $x
    } {{} {no timeout}}
    test event-13.2 {Tcl_WaitForFile procedure, readable} unixOnly {
	foreach i [after info] {
	    after cancel $i
	}
	after 100 set x timeout
	testfilehandler close
	testfilehandler create 1 off off
	set x "no timeout"
	set result [testfilehandler wait 1 readable 100]
	update
	testfilehandler close
	list $result $x
    } {{} timeout}
    test event-13.3 {Tcl_WaitForFile procedure, readable} unixOnly {
	foreach i [after info] {
	    after cancel $i
	}
	after 100 set x timeout
	testfilehandler close
	testfilehandler create 1 off off
	testfilehandler fillpartial 1
	set x "no timeout"
	set result [testfilehandler wait 1 readable 100]
	update
	testfilehandler close
	list $result $x
    } {readable {no timeout}}
    test event-13.4 {Tcl_WaitForFile procedure, writable} {unixOnly nonPortable} {
	foreach i [after info] {
	    after cancel $i
	}
	after 100 set x timeout
	testfilehandler close
	testfilehandler create 1 off off
	testfilehandler fill 1
	set x "no timeout"
	set result [testfilehandler wait 1 writable 0]
	update
	testfilehandler close
	list $result $x
    } {{} {no timeout}}
    test event-13.5 {Tcl_WaitForFile procedure, writable} {unixOnly nonPortable} {
	foreach i [after info] {
	    after cancel $i
	}
	after 100 set x timeout
	testfilehandler close
	testfilehandler create 1 off off
	testfilehandler fill 1
	set x "no timeout"
	set result [testfilehandler wait 1 writable 100]
	update
	testfilehandler close
	list $result $x
    } {{} timeout}
    test event-13.6 {Tcl_WaitForFile procedure, writable} unixOnly {
	foreach i [after info] {
	    after cancel $i
	}
	after 100 set x timeout
	testfilehandler close
	testfilehandler create 1 off off
	set x "no timeout"
	set result [testfilehandler wait 1 writable 100]
	update
	testfilehandler close
	list $result $x
    } {writable {no timeout}}
    test event-13.7 {Tcl_WaitForFile procedure, don't call other event handlers} unixOnly {
	foreach i [after info] {
	    after cancel $i
	}
	after 100 lappend x timeout
	after idle lappend x idle
	testfilehandler close
	testfilehandler create 1 off off
	set x ""
	set result [list [testfilehandler wait 1 readable 200] $x]
	update
	testfilehandler close
	lappend result $x
    } {{} {} {timeout idle}}
}

if {[info commands testfilewait] != ""} {
    test event-13.8 {Tcl_WaitForFile procedure, waiting indefinitely} unixOnly {
	set f [open "|sleep 2" r]
	set result ""
	lappend result [testfilewait $f readable 100]
	lappend result [testfilewait $f readable -1]
	close $f
	set result
    } {{} readable}
}

# cleanup
foreach i [after info] {
    after cancel $i
}
::tcltest::cleanupTests
return






|





|
>
>
>
>
>
>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
|
<







 







<
|
|
|
|
|
|
|
|
|




|
|
|
|
|
|
|
|
|
|



|
|
|
|
|
|
|
|
|




|
|
|
|
|
|
|
|
|
|



|
|
|
|
|
|
|
|
|
<







 







<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
<
|
|
|
|
|
|
|
|
<







5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155

156

157
158
159
160
161
162
163
...
279
280
281
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
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346

347
348
349
350
351
352
353
...
455
456
457
458
459
460
461

462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557


558
559
560
561
562
563
564
565

566
567
568
569
570
571
572
#
# Copyright (c) 1995-1997 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: event.test,v 1.1.2.6 1999/03/24 04:25:42 stanton Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

set ::tcltest::testConfig(testfilehandler) \
	[expr {[info commands testfilehandler] != {}}]
set ::tcltest::testConfig(testexithandler) \
	[expr {[info commands testexithandler] != {}}]
set ::tcltest::testConfig(testfilewait) \
	[expr {[info commands testfilewait] != {}}]


test event-1.1 {Tcl_CreateFileHandler, reading} {testfilehandler} {
    testfilehandler close
    testfilehandler create 0 readable off
    testfilehandler clear 0
    testfilehandler oneevent
    set result ""
    lappend result [testfilehandler counts 0]
    testfilehandler fillpartial 0
    testfilehandler oneevent
    lappend result [testfilehandler counts 0]
    testfilehandler oneevent
    lappend result [testfilehandler counts 0]
    testfilehandler close
    set result
} {{0 0} {1 0} {2 0}}
test event-1.2 {Tcl_CreateFileHandler, writing} {testfilehandler nonPortable} {
    # This test is non-portable because on some systems (e.g.
    # SunOS 4.1.3) pipes seem to be writable always.
    testfilehandler close
    testfilehandler create 0 off writable
    testfilehandler clear 0
    testfilehandler oneevent
    set result ""
    lappend result [testfilehandler counts 0]
    testfilehandler fillpartial 0
    testfilehandler oneevent
    lappend result [testfilehandler counts 0]
    testfilehandler fill 0
    testfilehandler oneevent
    lappend result [testfilehandler counts 0]
    testfilehandler close
    set result
} {{0 1} {0 2} {0 2}}
test event-1.3 {Tcl_DeleteFileHandler} {testfilehandler nonPortable} {
    testfilehandler close
    testfilehandler create 2 disabled disabled
    testfilehandler create 1 readable writable
    testfilehandler create 0 disabled disabled
    testfilehandler fillpartial 1
    set result ""
    testfilehandler oneevent
    lappend result [testfilehandler counts 1]
    testfilehandler oneevent
    lappend result [testfilehandler counts 1]
    testfilehandler oneevent
    lappend result [testfilehandler counts 1]
    testfilehandler create 1 off off
    testfilehandler oneevent
    lappend result [testfilehandler counts 1]
    testfilehandler close
    set result
} {{0 1} {1 1} {1 2} {0 0}}

test event-2.1 {Tcl_DeleteFileHandler} {testfilehandler nonPortable} {
    testfilehandler close
    testfilehandler create 2 disabled disabled
    testfilehandler create 1 readable writable
    testfilehandler fillpartial 1
    set result ""
    testfilehandler oneevent
    lappend result [testfilehandler counts 1]
    testfilehandler oneevent
    lappend result [testfilehandler counts 1]
    testfilehandler oneevent
    lappend result [testfilehandler counts 1]
    testfilehandler create 1 off off
    testfilehandler oneevent
    lappend result [testfilehandler counts 1]
    testfilehandler close
    set result
} {{0 1} {1 1} {1 2} {0 0}}
test event-2.2 {Tcl_DeleteFileHandler, fd reused & events still pending} {testfilehandler nonPortable} {
    testfilehandler close
    testfilehandler create 0 readable writable
    testfilehandler fillpartial 0
    set result ""
    testfilehandler oneevent
    lappend result [testfilehandler counts 0]
    testfilehandler close
    testfilehandler create 0 readable writable
    testfilehandler oneevent
    lappend result [testfilehandler counts 0]
    testfilehandler close
    set result
} {{0 1} {0 0}}

test event-3.1 {FileHandlerCheckProc, TCL_FILE_EVENTS off } {testfilehandler} {
    testfilehandler close
    testfilehandler create 1 readable writable
    testfilehandler fillpartial 1
    testfilehandler windowevent
    set result [testfilehandler counts 1]
    testfilehandler close
    set result
} {0 0}

test event-4.1 {FileHandlerEventProc, race between event and disabling} {testfilehandler nonPortable} {
    update
    testfilehandler close
    testfilehandler create 2 disabled disabled
    testfilehandler create 1 readable writable
    testfilehandler fillpartial 1
    set result ""
    testfilehandler oneevent
    lappend result [testfilehandler counts 1]
    testfilehandler oneevent
    lappend result [testfilehandler counts 1]
    testfilehandler oneevent
    lappend result [testfilehandler counts 1]
    testfilehandler create 1 disabled disabled
    testfilehandler oneevent
    lappend result [testfilehandler counts 1]
    testfilehandler close
    set result
} {{0 1} {1 1} {1 2} {0 0}}
test event-4.2 {FileHandlerEventProc, TCL_FILE_EVENTS off} {testfilehandler nonPortable} {
    update
    testfilehandler close
    testfilehandler create 1 readable writable
    testfilehandler create 2 readable writable
    testfilehandler fillpartial 1
    testfilehandler fillpartial 2
    testfilehandler oneevent
    set result ""
    lappend result [testfilehandler counts 1] [testfilehandler counts 2]
    testfilehandler windowevent
    lappend result [testfilehandler counts 1] [testfilehandler counts 2]
    testfilehandler close
    set result
} {{0 0} {0 1} {0 0} {0 1}}

update


test event-5.1 {Tcl_BackgroundError, HandleBgErrors procedures} {
    catch {rename bgerror {}}
    proc bgerror msg {
	global errorInfo errorCode x
	lappend x [list $msg $errorInfo $errorCode]
    }
................................................................................
# that. the other option would be to use fork a test but it
# then becomes more a file/exec test than a bgerror test.

# end of bgerror tests
catch {rename bgerror {}}



test event-8.1 {Tcl_CreateExitHandler procedure} {stdio testexithandler} {
    set child [open |[list [info nameofexecutable]] r+]
    puts $child "testexithandler create 41; testexithandler create 4"
    puts $child "testexithandler create 6; exit"
    flush $child
    set result [read $child]
    close $child
    set result
} {even 6
even 4
odd 41
}

test event-9.1 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} {
    set child [open |[list [info nameofexecutable]] r+]
    puts $child "testexithandler create 41; testexithandler create 4"
    puts $child "testexithandler create 6; testexithandler delete 41"
    puts $child "testexithandler create 16; exit"
    flush $child
    set result [read $child]
    close $child
    set result
} {even 16
even 6
even 4
}
test event-9.2 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} {
    set child [open |[list [info nameofexecutable]] r+]
    puts $child "testexithandler create 41; testexithandler create 4"
    puts $child "testexithandler create 6; testexithandler delete 4"
    puts $child "testexithandler create 16; exit"
    flush $child
    set result [read $child]
    close $child
    set result
    } {even 16
even 6
odd 41
}
test event-9.3 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} {
    set child [open |[list [info nameofexecutable]] r+]
    puts $child "testexithandler create 41; testexithandler create 4"
    puts $child "testexithandler create 6; testexithandler delete 6"
    puts $child "testexithandler create 16; exit"
    flush $child
    set result [read $child]
    close $child
    set result
} {even 16
even 4
odd 41
}
test event-9.4 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} {
    set child [open |[list [info nameofexecutable]] r+]
    puts $child "testexithandler create 41; testexithandler delete 41"
    puts $child "testexithandler create 16; exit"
    flush $child
    set result [read $child]
    close $child
    set result
} {even 16

}

test event-10.1 {Tcl_Exit procedure} {stdio} {
    set child [open |[list [info nameofexecutable]] r+]
    puts $child "exit 3"
    list [catch {close $child} msg] $msg [lindex $errorCode 0] \
        [lindex $errorCode 2]
................................................................................
    set y before
    set z before
    after 300
    update
    list $x $y $z
} {x-done before z-done}


test event-13.1 {Tcl_WaitForFile procedure, readable} {testfilehandler} {
    foreach i [after info] {
	after cancel $i
    }
    after 100 set x timeout
    testfilehandler close
    testfilehandler create 1 off off
    set x "no timeout"
    set result [testfilehandler wait 1 readable 0]
    update
    testfilehandler close
    list $result $x
} {{} {no timeout}}
test event-13.2 {Tcl_WaitForFile procedure, readable} testfilehandler {
    foreach i [after info] {
	after cancel $i
    }
    after 100 set x timeout
    testfilehandler close
    testfilehandler create 1 off off
    set x "no timeout"
    set result [testfilehandler wait 1 readable 100]
    update
    testfilehandler close
    list $result $x
} {{} timeout}
test event-13.3 {Tcl_WaitForFile procedure, readable} testfilehandler {
    foreach i [after info] {
	after cancel $i
    }
    after 100 set x timeout
    testfilehandler close
    testfilehandler create 1 off off
    testfilehandler fillpartial 1
    set x "no timeout"
    set result [testfilehandler wait 1 readable 100]
    update
    testfilehandler close
    list $result $x
} {readable {no timeout}}
test event-13.4 {Tcl_WaitForFile procedure, writable} {testfilehandler nonPortable} {
    foreach i [after info] {
	after cancel $i
    }
    after 100 set x timeout
    testfilehandler close
    testfilehandler create 1 off off
    testfilehandler fill 1
    set x "no timeout"
    set result [testfilehandler wait 1 writable 0]
    update
    testfilehandler close
    list $result $x
} {{} {no timeout}}
test event-13.5 {Tcl_WaitForFile procedure, writable} {testfilehandler nonPortable} {
    foreach i [after info] {
	after cancel $i
    }
    after 100 set x timeout
    testfilehandler close
    testfilehandler create 1 off off
    testfilehandler fill 1
    set x "no timeout"
    set result [testfilehandler wait 1 writable 100]
    update
    testfilehandler close
    list $result $x
} {{} timeout}
test event-13.6 {Tcl_WaitForFile procedure, writable} testfilehandler {
    foreach i [after info] {
	after cancel $i
    }
    after 100 set x timeout
    testfilehandler close
    testfilehandler create 1 off off
    set x "no timeout"
    set result [testfilehandler wait 1 writable 100]
    update
    testfilehandler close
    list $result $x
} {writable {no timeout}}
test event-13.7 {Tcl_WaitForFile procedure, don't call other event handlers} testfilehandler {
    foreach i [after info] {
	after cancel $i
    }
    after 100 lappend x timeout
    after idle lappend x idle
    testfilehandler close
    testfilehandler create 1 off off
    set x ""
    set result [list [testfilehandler wait 1 readable 200] $x]
    update
    testfilehandler close
    lappend result $x
} {{} {} {timeout idle}}



test event-13.8 {Tcl_WaitForFile procedure, waiting indefinitely} testfilewait {
    set f [open "|sleep 2" r]
    set result ""
    lappend result [testfilewait $f readable 100]
    lappend result [testfilewait $f readable -1]
    close $f
    set result
} {{} readable}


# cleanup
foreach i [after info] {
    after cancel $i
}
::tcltest::cleanupTests
return

Changes to tests/ioCmd.test.

8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
...
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
# Copyright (c) 1991-1994 The Regents of the University of California.
# 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: ioCmd.test,v 1.1.2.6 1999/03/24 02:49:19 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

removeFile test1
removeFile pipe
................................................................................
test iocmd-8.18 {fconfigure command / unix tty channel} {nonPortable unixOnly} {
	# might fail if /dev/ttya is unavailable
	set tty [open /dev/ttya]
	set r [list [catch {fconfigure $tty -blah blih} msg] $msg];
	close $tty;
	set r;
} {1 {bad option "-blah": should be one of -blocking, -buffering, -buffersize, -eofchar, -translation, or -mode}}
test iocmd-8.19 {fconfigure command / win tty channel} {pcOnly} {
	# might fail if com1 is unavailable
	set tty [open com1]
	set r [list [catch {fconfigure $tty -blah blih} msg] $msg];
	close $tty;
	set r;
} {1 {bad option "-blah": should be one of -blocking, -buffering, -buffersize, -eofchar, -translation, or -mode}}







|







 







|







8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
...
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
# Copyright (c) 1991-1994 The Regents of the University of California.
# 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: ioCmd.test,v 1.1.2.7 1999/03/24 04:25:42 stanton Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

removeFile test1
removeFile pipe
................................................................................
test iocmd-8.18 {fconfigure command / unix tty channel} {nonPortable unixOnly} {
	# might fail if /dev/ttya is unavailable
	set tty [open /dev/ttya]
	set r [list [catch {fconfigure $tty -blah blih} msg] $msg];
	close $tty;
	set r;
} {1 {bad option "-blah": should be one of -blocking, -buffering, -buffersize, -eofchar, -translation, or -mode}}
test iocmd-8.19 {fconfigure command / win tty channel} {nonPortable pcOnly} {
	# might fail if com1 is unavailable
	set tty [open com1]
	set r [list [catch {fconfigure $tty -blah blih} msg] $msg];
	close $tty;
	set r;
} {1 {bad option "-blah": should be one of -blocking, -buffering, -buffersize, -eofchar, -translation, or -mode}}

Changes to tests/winNotify.test.

6
7
8
9
10
11
12
13
14
15
16
17
18



19
20
21
22
23
24
25
..
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
...
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
#
# Copyright (c) 1997 by 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: winNotify.test,v 1.1.2.5 1999/03/24 02:49:52 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}




# There is no explicit test for InitNotifier or NotifierExitHandler

test winNotify-1.1 {Tcl_SetTimer: positive timeout} {pcOnly} {
    set done 0
    after 1000 { set done 1 }
    vwait done
    set done
................................................................................
    update
    after idle { incr x }
    after idle { incr y }
    update
    list $x $y
} {1 2}

test winNotify-3.1 {NotifierProc: non-modal normal timer} {pcOnly} {
    update
    set x 0
    foreach i [after info] {
	after cancel $i
    }
    after 500 { incr x; testeventloop done }
    testeventloop wait
    set x
} 1
test winNotify-3.2 {NotifierProc: non-modal normal timer, rescheduled} {pcOnly} {
    update
    set x 0
    foreach i [after info] {
	after cancel $i
    }
    after 500 { incr x; after 100 {incr x; testeventloop done }}
    testeventloop wait
................................................................................
	after cancel $i
    }
    set y 0
    after 500 { incr y; after 100 {incr x}}
    vwait x
    list $x $y
} {1 1}
test winNotify-3.5 {NotifierProc: non-modal idle timer} {pcOnly} {
    update
    set x 0
    foreach i [after info] {
	after cancel $i
    }
    after idle { incr x; testeventloop done }
    testeventloop wait
    set x
} 1
test winNotify-3.6 {NotifierProc: non-modal idle timer, rescheduled} {pcOnly} {
    update
    set x 0
    foreach i [after info] {
	after cancel $i
    }
    after idle { incr x; after idle {incr x; testeventloop done }}
    testeventloop wait






|





>
>
>







 







|









|







 







|









|







6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
..
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
...
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
#
# Copyright (c) 1997 by 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: winNotify.test,v 1.1.2.6 1999/03/24 04:25:42 stanton Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

set ::tcltest::testConfig(testeventloop) \
	[expr {[info commands testeventloop] != {}}]

# There is no explicit test for InitNotifier or NotifierExitHandler

test winNotify-1.1 {Tcl_SetTimer: positive timeout} {pcOnly} {
    set done 0
    after 1000 { set done 1 }
    vwait done
    set done
................................................................................
    update
    after idle { incr x }
    after idle { incr y }
    update
    list $x $y
} {1 2}

test winNotify-3.1 {NotifierProc: non-modal normal timer} {pcOnly testeventloop} {
    update
    set x 0
    foreach i [after info] {
	after cancel $i
    }
    after 500 { incr x; testeventloop done }
    testeventloop wait
    set x
} 1
test winNotify-3.2 {NotifierProc: non-modal normal timer, rescheduled} {pcOnly testeventloop} {
    update
    set x 0
    foreach i [after info] {
	after cancel $i
    }
    after 500 { incr x; after 100 {incr x; testeventloop done }}
    testeventloop wait
................................................................................
	after cancel $i
    }
    set y 0
    after 500 { incr y; after 100 {incr x}}
    vwait x
    list $x $y
} {1 1}
test winNotify-3.5 {NotifierProc: non-modal idle timer} {pcOnly testeventloop} {
    update
    set x 0
    foreach i [after info] {
	after cancel $i
    }
    after idle { incr x; testeventloop done }
    testeventloop wait
    set x
} 1
test winNotify-3.6 {NotifierProc: non-modal idle timer, rescheduled} {pcOnly testeventloop} {
    update
    set x 0
    foreach i [after info] {
	after cancel $i
    }
    after idle { incr x; after idle {incr x; testeventloop done }}
    testeventloop wait