1
2
3
4
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
|
{$mode objfpc}
uses
{$ifdef unix}
cthreads,
{$endif}
sysutils,
classes;
Const
wrSignaled = 0;
wrTimeout = 1;
wrAbandoned= 2;
wrError = 3;
type
tc = class(tthread)
procedure execute; override;
end;
torder = (o_destroy, o_post, o_sleeppost, o_waittimeoutabandon, o_waittimeoutsignal);
thelper = class(tthread)
private
forder: torder;
public
constructor create(order: torder);
procedure execute; override;
end;
var
event: pEventState;
waiting: boolean;
constructor thelper.create(order: torder);
begin
forder:=order;
inherited create(false);
end;
procedure thelper.execute;
var
res: longint;
begin
case forder of
o_destroy:
basiceventdestroy(event);
o_post:
basiceventsetevent(event);
o_sleeppost:
begin
sleep(1000);
basiceventsetevent(event);
end;
o_waittimeoutabandon:
begin
res:=basiceventWaitFor(1000,event);
if (res<>wrAbandoned) then
begin
writeln('error 1');
halt(1);
end;
end;
o_waittimeoutsignal:
begin
res:=basiceventWaitFor(1000,event);
if (res<>wrSignaled) then
begin
writeln('error 2');
halt(2);
end;
end;
end;
end;
procedure tc.execute;
begin
{ make sure we don't exit before this thread has initialised, since }
{ it can allocate memory in its initialisation, which would cause }
{ problems for heaptrc as it goes over the memory map in its exit code }
waiting:=true;
{ avoid deadlocks/bugs from causing this test to never quit }
sleep(1000*10);
writeln('error 3');
halt(3);
end;
var
help: thelper;
begin
waiting:=false;
tc.create(false);
event := BasicEventCreate(nil,false,false,'bla');
basiceventSetEvent(event);
if (basiceventWaitFor(cardinal(-1),event) <> wrSignaled) then
begin
writeln('error 4');
halt(4);
end;
basiceventSetEvent(event);
if (basiceventWaitFor(1000,event) <> wrSignaled) then
begin
writeln('error 5');
halt(5);
end;
{ shouldn't change anything }
basiceventResetEvent(event);
basiceventSetEvent(event);
{ shouldn't change anything }
basiceventSetEvent(event);
if (basiceventWaitFor(cardinal(-1),event) <> wrSignaled) then
begin
writeln('error 6');
halt(6);
end;
{ make sure the two BasicSetEvents aren't cumulative }
if (basiceventWaitFor(1000,event) <> wrTimeOut) then
begin
writeln('error 7');
halt(7);
end;
{$ifdef windows}
{ On windows event can not be "abandoned". Skipping this test }
basiceventdestroy(event);
{$else}
help:=thelper.create(o_waittimeoutabandon);
basiceventdestroy(event);
help.waitfor;
help.free;
{$endif}
event := BasicEventCreate(nil,false,false,'bla');
help:=thelper.create(o_waittimeoutsignal);
basiceventSetEvent(event);
help.waitfor;
help.free;
basiceventdestroy(event);
while not waiting do
sleep(20);
end.
|
