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

Contents of /trunk/lcorewsaasyncselect.pas

Parent Directory Parent Directory | Revision Log Revision Log


Revision 7 - (show annotations)
Sun Mar 30 01:02:40 2008 UTC (13 years, 2 months ago) by plugwash
File size: 7827 byte(s)
fix line ending and some other minor issues

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

Properties

Name Value
svn:executable

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