/[lcore]/trunk/lcorewsaasyncselect.pas
ViewVC logotype

Contents of /trunk/lcorewsaasyncselect.pas

Parent Directory Parent Directory | Revision Log Revision Log


Revision 149 - (show annotations)
Sun Sep 10 20:02:13 2017 UTC (3 months ago) by plugwash
File size: 8024 byte(s)
Replace obsolete/broken lcoregtklaz with new lcorelazarus
Rename lmessages to lcoremessages due to unit name conflict with Lazarus

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.

Properties

Name Value
svn:eol-style CRLF

No admin address has been configured">No admin address has been configured
ViewVC Help
Powered by ViewVC 1.1.5