OpenCores
URL https://opencores.org/ocsvn/or1k/or1k/trunk

Subversion Repositories or1k

[/] [or1k/] [trunk/] [insight/] [tcl/] [tests/] [event.test] - Blame information for rev 1765

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 578 markom
# This file contains a collection of tests for the procedures in the file
2
# tclEvent.c, which includes the "update", and "vwait" Tcl
3
# commands.  Sourcing this file into Tcl runs the tests and generates
4
# output for errors.  No output means no errors were found.
5
#
6
# Copyright (c) 1995-1997 Sun Microsystems, Inc.
7
#
8
# See the file "license.terms" for information on usage and redistribution
9
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
10
#
11
# RCS: @(#) $Id: event.test,v 1.1.1.1 2002-01-16 10:25:35 markom Exp $
12
 
13
if {[string compare test [info procs test]] == 1} then {source defs}
14
 
15
if {[catch {testfilehandler create 0 off off}] == 0 } {
16
    test event-1.1 {Tcl_CreateFileHandler, reading} {
17
        testfilehandler close
18
        testfilehandler create 0 readable off
19
        testfilehandler clear 0
20
        testfilehandler oneevent
21
        set result ""
22
        lappend result [testfilehandler counts 0]
23
        testfilehandler fillpartial 0
24
        testfilehandler oneevent
25
        lappend result [testfilehandler counts 0]
26
        testfilehandler oneevent
27
        lappend result [testfilehandler counts 0]
28
        testfilehandler close
29
        set result
30
    } {{0 0} {1 0} {2 0}}
31
    test event-1.2 {Tcl_CreateFileHandler, writing} {nonPortable} {
32
        # This test is non-portable because on some systems (e.g.
33
        # SunOS 4.1.3) pipes seem to be writable always.
34
        testfilehandler close
35
        testfilehandler create 0 off writable
36
        testfilehandler clear 0
37
        testfilehandler oneevent
38
        set result ""
39
        lappend result [testfilehandler counts 0]
40
        testfilehandler fillpartial 0
41
        testfilehandler oneevent
42
        lappend result [testfilehandler counts 0]
43
        testfilehandler fill 0
44
        testfilehandler oneevent
45
        lappend result [testfilehandler counts 0]
46
        testfilehandler close
47
        set result
48
    } {{0 1} {0 2} {0 2}}
49
    test event-1.3 {Tcl_DeleteFileHandler} {nonPortable} {
50
        testfilehandler close
51
        testfilehandler create 2 disabled disabled
52
        testfilehandler create 1 readable writable
53
        testfilehandler create 0 disabled disabled
54
        testfilehandler fillpartial 1
55
        set result ""
56
        testfilehandler oneevent
57
        lappend result [testfilehandler counts 1]
58
        testfilehandler oneevent
59
        lappend result [testfilehandler counts 1]
60
        testfilehandler oneevent
61
        lappend result [testfilehandler counts 1]
62
        testfilehandler create 1 off off
63
        testfilehandler oneevent
64
        lappend result [testfilehandler counts 1]
65
        testfilehandler close
66
        set result
67
    } {{0 1} {1 1} {1 2} {0 0}}
68
 
69
    test event-2.1 {Tcl_DeleteFileHandler} {nonPortable} {
70
        testfilehandler close
71
        testfilehandler create 2 disabled disabled
72
        testfilehandler create 1 readable writable
73
        testfilehandler fillpartial 1
74
        set result ""
75
        testfilehandler oneevent
76
        lappend result [testfilehandler counts 1]
77
        testfilehandler oneevent
78
        lappend result [testfilehandler counts 1]
79
        testfilehandler oneevent
80
        lappend result [testfilehandler counts 1]
81
        testfilehandler create 1 off off
82
        testfilehandler oneevent
83
        lappend result [testfilehandler counts 1]
84
        testfilehandler close
85
        set result
86
    } {{0 1} {1 1} {1 2} {0 0}}
87
    test event-2.2 {Tcl_DeleteFileHandler, fd reused & events still pending} {nonPortable} {
88
        testfilehandler close
89
        testfilehandler create 0 readable writable
90
        testfilehandler fillpartial 0
91
        set result ""
92
        testfilehandler oneevent
93
        lappend result [testfilehandler counts 0]
94
        testfilehandler close
95
        testfilehandler create 0 readable writable
96
        testfilehandler oneevent
97
        lappend result [testfilehandler counts 0]
98
        testfilehandler close
99
        set result
100
    } {{0 1} {0 0}}
101
 
102
    test event-3.1 {FileHandlerCheckProc, TCL_FILE_EVENTS off } {
103
        testfilehandler close
104
        testfilehandler create 1 readable writable
105
        testfilehandler fillpartial 1
106
        testfilehandler windowevent
107
        set result [testfilehandler counts 1]
108
        testfilehandler close
109
        set result
110
    } {0 0}
111
 
112
    test event-4.1 {FileHandlerEventProc, race between event and disabling} {nonPortable} {
113
        update
114
        testfilehandler close
115
        testfilehandler create 2 disabled disabled
116
        testfilehandler create 1 readable writable
117
        testfilehandler fillpartial 1
118
        set result ""
119
        testfilehandler oneevent
120
        lappend result [testfilehandler counts 1]
121
        testfilehandler oneevent
122
        lappend result [testfilehandler counts 1]
123
        testfilehandler oneevent
124
        lappend result [testfilehandler counts 1]
125
        testfilehandler create 1 disabled disabled
126
        testfilehandler oneevent
127
        lappend result [testfilehandler counts 1]
128
        testfilehandler close
129
        set result
130
    } {{0 1} {1 1} {1 2} {0 0}}
131
    test event-4.2 {FileHandlerEventProc, TCL_FILE_EVENTS off} {nonPortable} {
132
        update
133
        testfilehandler close
134
        testfilehandler create 1 readable writable
135
        testfilehandler create 2 readable writable
136
        testfilehandler fillpartial 1
137
        testfilehandler fillpartial 2
138
        testfilehandler oneevent
139
        set result ""
140
        lappend result [testfilehandler counts 1] [testfilehandler counts 2]
141
        testfilehandler windowevent
142
        lappend result [testfilehandler counts 1] [testfilehandler counts 2]
143
        testfilehandler close
144
        set result
145
    } {{0 0} {0 1} {0 0} {0 1}}
146
    testfilehandler close
147
    update
148
}
149
 
150
test event-5.1 {Tcl_BackgroundError, HandleBgErrors procedures} {
151
    catch {rename bgerror {}}
152
    proc bgerror msg {
153
        global errorInfo errorCode x
154
        lappend x [list $msg $errorInfo $errorCode]
155
    }
156
    after idle {error "a simple error"}
157
    after idle {open non_existent}
158
    after idle {set errorInfo foobar; set errorCode xyzzy}
159
    set x {}
160
    update idletasks
161
    rename bgerror {}
162
    set x
163
} {{{a simple error} {a simple error
164
    while executing
165
"error "a simple error""
166
    ("after" script)} NONE} {{couldn't open "non_existent": no such file or directory} {couldn't open "non_existent": no such file or directory
167
    while executing
168
"open non_existent"
169
    ("after" script)} {POSIX ENOENT {no such file or directory}}}}
170
test event-5.2 {Tcl_BackgroundError, HandleBgErrors procedures} {
171
    catch {rename bgerror {}}
172
    proc bgerror msg {
173
        global x
174
        lappend x $msg
175
        return -code break
176
    }
177
    after idle {error "a simple error"}
178
    after idle {open non_existent}
179
    set x {}
180
    update idletasks
181
    rename bgerror {}
182
    set x
183
} {{a simple error}}
184
 
185
test event-6.1 {BgErrorDeleteProc procedure} {
186
    catch {interp delete foo}
187
    interp create foo
188
    foo eval {
189
        proc bgerror args {
190
            global errorInfo
191
            set f [open err.out r+]
192
            seek $f 0 end
193
            puts $f "$args $errorInfo"
194
            close $f
195
        }
196
        after 100 {error "first error"}
197
        after 100 {error "second error"}
198
    }
199
    makeFile Unmodified err.out
200
    after 100 {interp delete foo}
201
    after 200
202
    update
203
    set f [open err.out r]
204
    set result [read $f]
205
    close $f
206
    removeFile err.out
207
    set result
208
} {Unmodified
209
}
210
 
211
test event-7.1 {bgerror / regular} {
212
    set errRes {}
213
    proc bgerror {err} {
214
        global errRes;
215
        set errRes $err;
216
    }
217
    after 0 {error err1}
218
    vwait errRes;
219
    set errRes;
220
} err1
221
 
222
test event-7.2 {bgerror / accumulation} {
223
    set errRes {}
224
    proc bgerror {err} {
225
        global errRes;
226
        lappend errRes $err;
227
    }
228
    after 0 {error err1}
229
    after 0 {error err2}
230
    after 0 {error err3}
231
    update
232
    set errRes;
233
} {err1 err2 err3}
234
 
235
test event-7.3 {bgerror / accumulation / break} {
236
    set errRes {}
237
    proc bgerror {err} {
238
        global errRes;
239
        lappend errRes $err;
240
        return -code break "skip!";
241
    }
242
    after 0 {error err1}
243
    after 0 {error err2}
244
    after 0 {error err3}
245
    update
246
    set errRes;
247
} err1
248
 
249
test event-7.4 {tkerror is nothing special anymore to tcl} {
250
    set errRes {}
251
    # we don't just rename bgerror to empty because it could then
252
    # be autoloaded...
253
    proc bgerror {err} {
254
        global errRes;
255
        lappend errRes "bg:$err";
256
    }
257
    proc tkerror {err} {
258
        global errRes;
259
        lappend errRes "tk:$err";
260
    }
261
    after 0 {error err1}
262
    update
263
    rename tkerror {}
264
    set errRes
265
} bg:err1
266
 
267
# someday : add a test checking that
268
# when there is no bgerror, an error msg goes to stderr
269
# ideally one would use sub interp and transfer a fake stderr
270
# to it, unfortunatly the current interp tcl API does not allow
271
# that. the other option would be to use fork a test but it
272
# then becomes more a file/exec test than a bgerror test.
273
 
274
# end of bgerror tests
275
catch {rename bgerror {}}
276
 
277
 
278
if {[info commands testexithandler] != ""} {
279
    test event-8.1 {Tcl_CreateExitHandler procedure} {stdio} {
280
        set child [open |[list [info nameofexecutable]] r+]
281
        puts $child "testexithandler create 41; testexithandler create 4"
282
        puts $child "testexithandler create 6; exit"
283
        flush $child
284
        set result [read $child]
285
        close $child
286
        set result
287
    } {even 6
288
even 4
289
odd 41
290
}
291
 
292
    test event-9.1 {Tcl_DeleteExitHandler procedure} {stdio} {
293
        set child [open |[list [info nameofexecutable]] r+]
294
        puts $child "testexithandler create 41; testexithandler create 4"
295
        puts $child "testexithandler create 6; testexithandler delete 41"
296
        puts $child "testexithandler create 16; exit"
297
        flush $child
298
        set result [read $child]
299
        close $child
300
        set result
301
    } {even 16
302
even 6
303
even 4
304
}
305
    test event-9.2 {Tcl_DeleteExitHandler procedure} {stdio} {
306
        set child [open |[list [info nameofexecutable]] r+]
307
        puts $child "testexithandler create 41; testexithandler create 4"
308
        puts $child "testexithandler create 6; testexithandler delete 4"
309
        puts $child "testexithandler create 16; exit"
310
        flush $child
311
        set result [read $child]
312
        close $child
313
        set result
314
    } {even 16
315
even 6
316
odd 41
317
}
318
    test event-9.3 {Tcl_DeleteExitHandler procedure} {stdio} {
319
        set child [open |[list [info nameofexecutable]] r+]
320
        puts $child "testexithandler create 41; testexithandler create 4"
321
        puts $child "testexithandler create 6; testexithandler delete 6"
322
        puts $child "testexithandler create 16; exit"
323
        flush $child
324
        set result [read $child]
325
        close $child
326
        set result
327
    } {even 16
328
even 4
329
odd 41
330
}
331
    test event-9.4 {Tcl_DeleteExitHandler procedure} {stdio} {
332
        set child [open |[list [info nameofexecutable]] r+]
333
        puts $child "testexithandler create 41; testexithandler delete 41"
334
        puts $child "testexithandler create 16; exit"
335
        flush $child
336
        set result [read $child]
337
        close $child
338
        set result
339
    } {even 16
340
}
341
}
342
 
343
test event-10.1 {Tcl_Exit procedure} {stdio} {
344
    set child [open |[list [info nameofexecutable]] r+]
345
    puts $child "exit 3"
346
    list [catch {close $child} msg] $msg [lindex $errorCode 0] \
347
        [lindex $errorCode 2]
348
} {1 {child process exited abnormally} CHILDSTATUS 3}
349
 
350
test event-11.1 {Tcl_VwaitCmd procedure} {
351
    list [catch {vwait} msg] $msg
352
} {1 {wrong # args: should be "vwait name"}}
353
test event-11.2 {Tcl_VwaitCmd procedure} {
354
    list [catch {vwait a b} msg] $msg
355
} {1 {wrong # args: should be "vwait name"}}
356
test event-11.3 {Tcl_VwaitCmd procedure} {
357
    catch {unset x}
358
    set x 1
359
    list [catch {vwait x(1)} msg] $msg
360
} {1 {can't trace "x(1)": variable isn't array}}
361
test event-11.4 {Tcl_VwaitCmd procedure} {
362
    foreach i [after info] {
363
        after cancel $i
364
    }
365
    after 10; update; # On Mac make sure update won't take long
366
    after 100 {set x x-done}
367
    after 200 {set y y-done}
368
    after 300 {set z z-done}
369
    after idle {set q q-done}
370
    set x before
371
    set y before
372
    set z before
373
    set q before
374
    list [vwait y] $x $y $z $q
375
} {{} x-done y-done before q-done}
376
 
377
foreach i [after info] {
378
    after cancel $i
379
}
380
 
381
test event-11.5 {Tcl_VwaitCmd procedure: round robin scheduling, 2 sources} {socket} {
382
    set f1 [open test1 w]
383
    proc accept {s args} {
384
        puts $s foobar
385
        close $s
386
    }
387
    set s1 [socket -server accept 5001]
388
    set s2 [socket 127.0.0.1 5001]
389
    close $s1
390
    set x 0
391
    set y 0
392
    set z 0
393
    fileevent $s2 readable { incr z }
394
    vwait z
395
    fileevent $f1 writable { incr x; if { $y == 3 } { set z done } }
396
    fileevent $s2 readable { incr y; if { $x == 3 } { set z done } }
397
    vwait z
398
    close $f1
399
    close $s2
400
    file delete test1 test2
401
    list $x $y $z
402
} {3 3 done}
403
test event-11.6 {Tcl_VwaitCmd procedure: round robin scheduling, same source} {
404
    file delete test1 test2
405
    set f1 [open test1 w]
406
    set f2 [open test2 w]
407
    set x 0
408
    set y 0
409
    set z 0
410
    update
411
    fileevent $f1 writable { incr x; if { $y == 3 } { set z done } }
412
    fileevent $f2 writable { incr y; if { $x == 3 } { set z done } }
413
    vwait z
414
    close $f1
415
    close $f2
416
    file delete test1 test2
417
    list $x $y $z
418
} {3 3 done}
419
 
420
 
421
test event-12.1 {Tcl_UpdateCmd procedure} {
422
    list [catch {update a b} msg] $msg
423
} {1 {wrong # args: should be "update ?idletasks?"}}
424
test event-12.2 {Tcl_UpdateCmd procedure} {
425
    list [catch {update bogus} msg] $msg
426
} {1 {bad option "bogus": must be idletasks}}
427
test event-12.3 {Tcl_UpdateCmd procedure} {
428
    foreach i [after info] {
429
        after cancel $i
430
    }
431
    after 500 {set x after}
432
    after idle {set y after}
433
    after idle {set z "after, y = $y"}
434
    set x before
435
    set y before
436
    set z before
437
    update idletasks
438
    list $x $y $z
439
} {before after {after, y = after}}
440
test event-12.4 {Tcl_UpdateCmd procedure} {
441
    foreach i [after info] {
442
        after cancel $i
443
    }
444
    after 10; update; # On Mac make sure update won't take long
445
    after 200 {set x x-done}
446
    after 600 {set y y-done}
447
    after idle {set z z-done}
448
    set x before
449
    set y before
450
    set z before
451
    after 300
452
    update
453
    list $x $y $z
454
} {x-done before z-done}
455
 
456
if {[info commands testfilehandler] != ""} {
457
    test event-13.1 {Tcl_WaitForFile procedure, readable} unixOnly {
458
        foreach i [after info] {
459
            after cancel $i
460
        }
461
        after 100 set x timeout
462
        testfilehandler close
463
        testfilehandler create 1 off off
464
        set x "no timeout"
465
        set result [testfilehandler wait 1 readable 0]
466
        update
467
        testfilehandler close
468
        list $result $x
469
    } {{} {no timeout}}
470
    test event-13.2 {Tcl_WaitForFile procedure, readable} unixOnly {
471
        foreach i [after info] {
472
            after cancel $i
473
        }
474
        after 100 set x timeout
475
        testfilehandler close
476
        testfilehandler create 1 off off
477
        set x "no timeout"
478
        set result [testfilehandler wait 1 readable 100]
479
        update
480
        testfilehandler close
481
        list $result $x
482
    } {{} timeout}
483
    test event-13.3 {Tcl_WaitForFile procedure, readable} unixOnly {
484
        foreach i [after info] {
485
            after cancel $i
486
        }
487
        after 100 set x timeout
488
        testfilehandler close
489
        testfilehandler create 1 off off
490
        testfilehandler fillpartial 1
491
        set x "no timeout"
492
        set result [testfilehandler wait 1 readable 100]
493
        update
494
        testfilehandler close
495
        list $result $x
496
    } {readable {no timeout}}
497
    test event-13.4 {Tcl_WaitForFile procedure, writable} {unixOnly nonPortable} {
498
        foreach i [after info] {
499
            after cancel $i
500
        }
501
        after 100 set x timeout
502
        testfilehandler close
503
        testfilehandler create 1 off off
504
        testfilehandler fill 1
505
        set x "no timeout"
506
        set result [testfilehandler wait 1 writable 0]
507
        update
508
        testfilehandler close
509
        list $result $x
510
    } {{} {no timeout}}
511
    test event-13.5 {Tcl_WaitForFile procedure, writable} {unixOnly nonPortable} {
512
        foreach i [after info] {
513
            after cancel $i
514
        }
515
        after 100 set x timeout
516
        testfilehandler close
517
        testfilehandler create 1 off off
518
        testfilehandler fill 1
519
        set x "no timeout"
520
        set result [testfilehandler wait 1 writable 100]
521
        update
522
        testfilehandler close
523
        list $result $x
524
    } {{} timeout}
525
    test event-13.6 {Tcl_WaitForFile procedure, writable} unixOnly {
526
        foreach i [after info] {
527
            after cancel $i
528
        }
529
        after 100 set x timeout
530
        testfilehandler close
531
        testfilehandler create 1 off off
532
        set x "no timeout"
533
        set result [testfilehandler wait 1 writable 100]
534
        update
535
        testfilehandler close
536
        list $result $x
537
    } {writable {no timeout}}
538
    test event-13.7 {Tcl_WaitForFile procedure, don't call other event handlers} unixOnly {
539
        foreach i [after info] {
540
            after cancel $i
541
        }
542
        after 100 lappend x timeout
543
        after idle lappend x idle
544
        testfilehandler close
545
        testfilehandler create 1 off off
546
        set x ""
547
        set result [list [testfilehandler wait 1 readable 200] $x]
548
        update
549
        testfilehandler close
550
        lappend result $x
551
    } {{} {} {timeout idle}}
552
}
553
 
554
if {[info commands testfilewait] != ""} {
555
    test event-13.8 {Tcl_WaitForFile procedure, waiting indefinitely} unixOnly {
556
        set f [open "|sleep 2" r]
557
        set result ""
558
        lappend result [testfilewait $f readable 100]
559
        lappend result [testfilewait $f readable -1]
560
        close $f
561
        set result
562
    } {{} readable}
563
}
564
 
565
foreach i [after info] {
566
    after cancel $i
567
}

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.