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

Contents of /trunk/lcorewsaasyncselect.pas

Parent Directory Parent Directory | Revision Log Revision Log


Revision 135 - (show annotations)
Thu Mar 13 21:27:50 2014 UTC (5 years, 7 months ago) by beware
File size: 7996 byte(s)
removed incorrect executable status from files
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 onsessionavailible 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 end;
170 type
171 twcoretimer = wcore.tltimer;
172
173 function twintimerwrapperinterface.createwrappedtimer : tobject;
174 begin
175 result := twcoretimer.create(nil);
176 end;
177 procedure twintimerwrapperinterface.setontimer(wrappedtimer : tobject;newvalue:tnotifyevent);
178 begin
179 twcoretimer(wrappedtimer).ontimer := newvalue;
180 end;
181 procedure twintimerwrapperinterface.setenabled(wrappedtimer : tobject;newvalue : boolean);
182 begin
183 twcoretimer(wrappedtimer).enabled := newvalue;
184 end;
185
186
187 procedure twintimerwrapperinterface.setinterval(wrappedtimer : tobject;newvalue : integer);
188 begin
189 twcoretimer(wrappedtimer).interval := newvalue;
190 end;
191
192 var
193 MyWindowClass : TWndClass = (style : 0;
194 lpfnWndProc : @MyWindowProc;
195 cbClsExtra : 0;
196 cbWndExtra : 0;
197 hInstance : 0;
198 hIcon : 0;
199 hCursor : 0;
200 hbrBackground : 0;
201 lpszMenuName : nil;
202 lpszClassName : 'lcoreClass');
203 GInitData: TWSAData;
204
205 var
206 inited:boolean;
207 procedure lcoreinit;
208 begin
209 if (inited) then exit;
210
211 dnswin.init;
212
213 eventcore := twineventcore.create;
214 if Windows.RegisterClass(MyWindowClass) = 0 then halt;
215 //writeln('about to create lcore handle, hinstance=',hinstance);
216 hwndlcore := CreateWindowEx(WS_EX_TOOLWINDOW,
217 MyWindowClass.lpszClassName,
218 '', { Window name }
219 WS_POPUP, { Window Style }
220 0, 0, { X, Y }
221 0, 0, { Width, Height }
222 0, { hWndParent }
223 0, { hMenu }
224 HInstance, { hInstance }
225 nil); { CreateParam }
226 //writeln('lcore hwnd is ',hwndlcore);
227 //writeln('last error is ',GetLastError);
228 onaddtask := winaddtask;
229 timerwrapperinterface := twintimerwrapperinterface.create(nil);
230
231 WSAStartup(2, GInitData);
232 absoloutemaxs := maxlongint;
233
234 wcoreinit;
235
236 inited := true;
237 end;
238
239 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.22