1 |
unit lcorewsaasyncselect;
|
2 |
|
3 |
interface
|
4 |
|
5 |
procedure lcoreinit;
|
6 |
|
7 |
implementation
|
8 |
|
9 |
uses
|
10 |
dnswin, //to call init
|
11 |
wcore,lcore,bsearchtree,sysutils,windows,winsock,pgtypes,messages,classes,lsocket;
|
12 |
|
13 |
type
|
14 |
twineventcore=class(teventcore)
|
15 |
public
|
16 |
procedure processmessages; override;
|
17 |
procedure messageloop; override;
|
18 |
procedure exitmessageloop;override;
|
19 |
procedure setfdreverse(fd : integer;reverseto : tlasio); override;
|
20 |
procedure rmasterset(fd : integer;islistensocket : boolean); override;
|
21 |
procedure rmasterclr(fd: integer); override;
|
22 |
procedure wmasterset(fd : integer); override;
|
23 |
procedure wmasterclr(fd: integer); override;
|
24 |
end;
|
25 |
const
|
26 |
wm_dotasks=wm_user+1;
|
27 |
type
|
28 |
twintimerwrapperinterface=class(ttimerwrapperinterface)
|
29 |
public
|
30 |
function createwrappedtimer : tobject;override;
|
31 |
// procedure setinitialevent(wrappedtimer : tobject;newvalue : boolean);override;
|
32 |
procedure setontimer(wrappedtimer : tobject;newvalue:tnotifyevent);override;
|
33 |
procedure setenabled(wrappedtimer : tobject;newvalue : boolean);override;
|
34 |
procedure setinterval(wrappedtimer : tobject;newvalue : integer);override;
|
35 |
end;
|
36 |
|
37 |
procedure twineventcore.processmessages;
|
38 |
begin
|
39 |
wcore.processmessages;//pass off to wcore
|
40 |
end;
|
41 |
procedure twineventcore.messageloop;
|
42 |
begin
|
43 |
wcore.messageloop; //pass off to wcore
|
44 |
end;
|
45 |
procedure twineventcore.exitmessageloop;
|
46 |
begin
|
47 |
wcore.exitmessageloop;
|
48 |
end;
|
49 |
var
|
50 |
fdreverse : thashtable;
|
51 |
fdwatches : thashtable;
|
52 |
|
53 |
procedure twineventcore.setfdreverse(fd : integer;reverseto : tlasio);
|
54 |
begin
|
55 |
if findtree(@fdreverse,inttostr(fd)) <> nil then deltree(@fdreverse,inttostr(fd));
|
56 |
if reverseto <> nil then addtree(@fdreverse,inttostr(fd),reverseto);
|
57 |
end;
|
58 |
|
59 |
var
|
60 |
hwndlcore : hwnd;
|
61 |
procedure dowsaasyncselect(fd:integer; leventadd: integer; leventremove : integer);
|
62 |
var
|
63 |
leventold : integer;
|
64 |
leventnew : integer;
|
65 |
wsaaresult : integer;
|
66 |
begin
|
67 |
leventold := taddrint(findtree(@fdwatches,inttostr(fd)));
|
68 |
leventnew := leventold or leventadd;
|
69 |
leventnew := leventnew and not leventremove;
|
70 |
if leventold <> leventnew then begin
|
71 |
if leventold <> 0 then deltree(@fdwatches,inttostr(fd));
|
72 |
if leventnew <> 0 then addtree(@fdwatches,inttostr(fd),pointer(leventnew));
|
73 |
end;
|
74 |
wsaaresult := wsaasyncselect(fd,hwndlcore,wm_user,leventnew);
|
75 |
|
76 |
end;
|
77 |
|
78 |
|
79 |
//to allow detection of errors:
|
80 |
//if we are asked to monitor for read or accept we also monitor for close
|
81 |
//if we are asked to monitor for write we also monitor for connect
|
82 |
|
83 |
|
84 |
procedure twineventcore.rmasterset(fd : integer;islistensocket : boolean);
|
85 |
begin
|
86 |
if islistensocket then begin
|
87 |
// writeln('setting accept watch for socket number ',fd);
|
88 |
dowsaasyncselect(fd,FD_ACCEPT or FD_CLOSE,0);
|
89 |
end else begin
|
90 |
// writeln('setting read watch for socket number',fd);
|
91 |
dowsaasyncselect(fd,FD_READ or FD_CLOSE,0);
|
92 |
end;
|
93 |
end;
|
94 |
procedure twineventcore.rmasterclr(fd: integer);
|
95 |
begin
|
96 |
//writeln('clearing read of accept watch for socket number ',fd);
|
97 |
dowsaasyncselect(fd,0,FD_ACCEPT or FD_READ or FD_CLOSE);
|
98 |
end;
|
99 |
procedure twineventcore.wmasterset(fd : integer);
|
100 |
begin
|
101 |
dowsaasyncselect(fd,FD_WRITE or FD_CONNECT,0);
|
102 |
end;
|
103 |
|
104 |
procedure twineventcore.wmasterclr(fd: integer);
|
105 |
begin
|
106 |
dowsaasyncselect(fd,0,FD_WRITE or FD_CONNECT);
|
107 |
end;
|
108 |
|
109 |
var
|
110 |
tasksoutstanding : boolean;
|
111 |
|
112 |
function MyWindowProc(
|
113 |
ahWnd : HWND;
|
114 |
auMsg : Integer;
|
115 |
awParam : WPARAM;
|
116 |
alParam : LPARAM): Integer; stdcall;
|
117 |
var
|
118 |
socket : integer;
|
119 |
event : integer;
|
120 |
error : integer;
|
121 |
readtrigger : boolean;
|
122 |
writetrigger : boolean;
|
123 |
lasio : tlasio;
|
124 |
begin
|
125 |
// writeln('got a message');
|
126 |
Result := 0; // This means we handled the message
|
127 |
if (ahwnd=hwndlcore) and (aumsg=wm_user) then begin
|
128 |
// writeln('it appears to be a response to our wsaasyncselect');
|
129 |
socket := awparam;
|
130 |
event := alparam and $FFFF;
|
131 |
error := alparam shr 16;
|
132 |
// writeln('socket=',socket,' event=',event,' error=',error);
|
133 |
readtrigger := false;
|
134 |
writetrigger := false;
|
135 |
lasio := findtree(@fdreverse,inttostr(socket));
|
136 |
if assigned(lasio) then begin
|
137 |
if (error <> 0) or ((event and FD_CLOSE) <> 0) then begin
|
138 |
if (lasio.state = wsconnecting) and (error <> 0) then begin
|
139 |
if lasio is tlsocket then tlsocket(lasio).connectionfailedhandler(error)
|
140 |
end else begin
|
141 |
lasio.internalclose(error);
|
142 |
end;
|
143 |
end else begin
|
144 |
if (event and (FD_READ or FD_ACCEPT)) <> 0 then readtrigger := true;
|
145 |
if (event and (FD_WRITE)) <> 0 then writetrigger := true;
|
146 |
|
147 |
if readtrigger or writetrigger then lasio.handlefdtrigger(readtrigger,writetrigger);
|
148 |
end;
|
149 |
// don't reset the event manually for listen sockets to avoid unwanted
|
150 |
// extra onsessionavailable events
|
151 |
if (taddrint(findtree(@fdwatches,inttostr(socket))) and (FD_ACCEPT)) = 0 then dowsaasyncselect(socket,0,0); // if not a listen socket reset watches
|
152 |
end;
|
153 |
end else if (ahwnd=hwndlcore) and (aumsg=wm_dotasks) then begin
|
154 |
//writeln('processing tasks');
|
155 |
tasksoutstanding := false;
|
156 |
processtasks;
|
157 |
end else begin
|
158 |
//writeln('passing unknown message to defwindowproc');
|
159 |
//not passing unknown messages on to defwindowproc will cause window
|
160 |
//creation to fail! --plugwash
|
161 |
Result := DefWindowProc(ahWnd, auMsg, awParam, alParam)
|
162 |
end;
|
163 |
|
164 |
end;
|
165 |
|
166 |
procedure winaddtask(ahandler:ttaskevent;aobj:tobject;awparam,alparam:longint);
|
167 |
begin
|
168 |
if not tasksoutstanding then PostMessage(hwndlcore,wm_dotasks,0,0);
|
169 |
tasksoutstanding := true;
|
170 |
end;
|
171 |
type
|
172 |
twcoretimer = wcore.tltimer;
|
173 |
|
174 |
function twintimerwrapperinterface.createwrappedtimer : tobject;
|
175 |
begin
|
176 |
result := twcoretimer.create(nil);
|
177 |
end;
|
178 |
procedure twintimerwrapperinterface.setontimer(wrappedtimer : tobject;newvalue:tnotifyevent);
|
179 |
begin
|
180 |
twcoretimer(wrappedtimer).ontimer := newvalue;
|
181 |
end;
|
182 |
procedure twintimerwrapperinterface.setenabled(wrappedtimer : tobject;newvalue : boolean);
|
183 |
begin
|
184 |
twcoretimer(wrappedtimer).enabled := newvalue;
|
185 |
end;
|
186 |
|
187 |
|
188 |
procedure twintimerwrapperinterface.setinterval(wrappedtimer : tobject;newvalue : integer);
|
189 |
begin
|
190 |
twcoretimer(wrappedtimer).interval := newvalue;
|
191 |
end;
|
192 |
|
193 |
var
|
194 |
MyWindowClass : TWndClass = (style : 0;
|
195 |
lpfnWndProc : @MyWindowProc;
|
196 |
cbClsExtra : 0;
|
197 |
cbWndExtra : 0;
|
198 |
hInstance : 0;
|
199 |
hIcon : 0;
|
200 |
hCursor : 0;
|
201 |
hbrBackground : 0;
|
202 |
lpszMenuName : nil;
|
203 |
lpszClassName : 'lcoreClass');
|
204 |
GInitData: TWSAData;
|
205 |
|
206 |
var
|
207 |
inited:boolean;
|
208 |
procedure lcoreinit;
|
209 |
begin
|
210 |
if (inited) then exit;
|
211 |
|
212 |
dnswin.init;
|
213 |
|
214 |
eventcore := twineventcore.create;
|
215 |
if Windows.RegisterClass(MyWindowClass) = 0 then halt;
|
216 |
//writeln('about to create lcore handle, hinstance=',hinstance);
|
217 |
hwndlcore := CreateWindowEx(WS_EX_TOOLWINDOW,
|
218 |
MyWindowClass.lpszClassName,
|
219 |
'', { Window name }
|
220 |
WS_POPUP, { Window Style }
|
221 |
0, 0, { X, Y }
|
222 |
0, 0, { Width, Height }
|
223 |
0, { hWndParent }
|
224 |
0, { hMenu }
|
225 |
HInstance, { hInstance }
|
226 |
nil); { CreateParam }
|
227 |
//writeln('lcore hwnd is ',hwndlcore);
|
228 |
//writeln('last error is ',GetLastError);
|
229 |
onaddtask := winaddtask;
|
230 |
timerwrapperinterface := twintimerwrapperinterface.create(nil);
|
231 |
|
232 |
WSAStartup(2, GInitData);
|
233 |
absolutemaxs := maxlongint;
|
234 |
|
235 |
wcoreinit;
|
236 |
|
237 |
inited := true;
|
238 |
end;
|
239 |
|
240 |
end.
|